PROGRAM cadx

! Code converted using TO_F90 by Alan Miller
! Date: 2013-05-26  Time: 22:01:46

!-------------------------------------------------------------------------

!   Executive routine for program CADAC, Version 3.0  Date: June 2000


!--Program History--------------------------------------------------------

!  2000 Jun   Version update to coincide with new CADAC Studio

!  2000 Feb   Eliminated the MINIT variable in C(1600) to be greater than 99
!             for SWEEP cases.  In order to signal a SWEEP execution, a
!             SWEEP/NOSWEEP item must be added to the HEAD.ASC header.

!             Added error handler routine when reading CADIN.ASC file.
!             This alerts the user to the error record in the CADIN.ASC
!             file.  This routine also allows for full line comment records
!             indicated by the 04 in columns 1 and 2.
!             Subroutines changed: RDI1_PRIM_TRAJ
!                                  RDI1_16CARD
!                                  RDI2_RDCARD
!                                  SAV_INSTREAM

!  1999 Jun   Added a flag reset for reading from CSAVE.ASC file.  When the
!             run number flag, JRUN, is reset to 1 at the end of a multi-run
!             case, the ISAVE flag is also reset to indicate the start of
!             a new group trajectory.

!  1998 Sep   Default the CRITMAX value to zero unless CRITMAX enterd as
!             greater than CRITVAL.  This is will allow the SWEEP program
!             to pick up the T values as designated by TRCOND.

!             The critical variable output has been fixed with respect to
!             output on TABOUT.  If the SWEEP trajectory does not reach the
!             correct end (LCONV > 2) the CritMax value is written as the
!             critical variable value.

!             The test for the critical variable has been modified with respect
!             to the SWEEP modes.  The criteria testing starts with the
!             critical variable being less than the critical value.  This is
!             true for SWEEP modes 4 and 5 only.

!  1998 May   Removed the FUNCTION RANF to be kept in the UTL2.FOR file.

!             Changed the Unit ID for TABOUT back to 6 such that all output
!             will written to standard output or TABOUT only.  Using the
!             Digital FORTRAN compiler, all output will be written to
!             TABOUT if indicated by TABOUTASC keyword in the HEAD.ASC file
!             All output will be written to the screen by default if no TABOUT
!             file indicated.

!  1998 Apr   Added call to SWEEPI in subroutine AUXI for SWEEP initialization

!             Changed the Unit ID for the TABOUT (tabular output) file
!             from 6 to 8.  This change will allow data to be written to
!             tabout and the screen during CADAC executions.  This change was
!             brought about when using the Digital Visual FORTRAN v5.0A.
!             Previous versions of Microsoft FORTRAN allowed writing to unit 6
!             as a file and writing to * for screen output; this was not supported
!             in Digital's FORTRAN compiler.


!  1997 Sep   New output files created for use with the Real-Time CADAC
!             with associated file ids and flags.

!             New HEADER flags (for RT-CADAC) on the HEAD.ASC file:
!                 (NO)INITASC/(NO)INITBIN    Flags for RT initialization file
!                 (NO)TRACKASC/(N0)TRACKBIN  Flags for RT Track data file

!             New File IDS (for RT CADAC):
!                 ID_INITASC   - file ID for INIT.ASC  = 50
!                 ID_INITBIN   - file ID for INIT.BIN  = 51
!                 ID_TRACKASC  - file ID for TRACK.ASC = 60
!                 ID_TRACKBIN  - file ID for TRACK.BIN = 61

!             New output data files (for RT CADAC):
!                 INIT.ASC  - ascii RT initialization data file
!                 INIT.BIN  - binary RT initialization data file
!                 TRACK.BIN - ascii RT track data file
!                 TRACK.BIN - binary RT track data file

!             The read header plot variable routine (RDH1_PVAR) was
!             changed to incorporate the new column 1 values.
!             Column 1 is now to indicate if the variable on that record
!             will be used for the RT CADAC output files generated by CADAC.
!             An I in column 1 indicates the variable is to be used for the
!             initialization file (INIT.ASC/BIN).  A T indicates the
!             variable will be used for the track data file (TRACK.ASC/BIN).
!             A B indicates the variable will be used for both RT files.
!             The * comment record is maintained.

!             A new COMMON was added to send the First Time Write Flag to the
!             INIT.ASC/BIN file
!             COMMOM /FIRSTI/ FINIT (Logical)

!  1997 May   New Sweep methodology added: SWEEP5. This methodology now
!             records impact information for a complete miss and
!             performs a binary search as the trajectories are
!             generated.  This new method is not fully checked out at this
!             time and therefore, SWEEP5 is a beta release.

!             LCONV = 5 for end of trajectory by staging - set in STGE3

!             SWEEP.ASC   renamed to IMPACT.ASC
!             SWEEP7.ASC  renamed to IMPACT7.ASC
!             SWEEP10.ASC renamed to IMPACT10.ASC
!             ID_SWEEP    renamed to ID_IMPACT
!             ID_SWEEP7   renamed to ID_IMPACT7
!             ID_SWEEP10  renamed to ID_IMPACT10

!             For SWEEP mode 4 and 5 impact data is written to IMPACT.ASC
!             file for all trajectories, either "hit" or "miss".  For
!             "miss" trajectories, the critical value is replaced by
!             CRITMAX and this new value is written to output files.

!  1995 Mar   Program converted to MS F32 and the files were renamed
!             The program was renamed to CADX1.  Additional output
!             options were added to the first line of the HEAD.ASC
!             file:  TRAJBIN, NOTRAJBIN, TRAJASC, NOTRAJASC, STATBIN,
!             NOSTATBIN, STATASC, NOSTATASC, TABOUT, NOTABOUT.  In
!             addition, file unit numbers were changed to variables.

!  1993       Program converted to PC.
!             These modifications necessary to the conversion included:
!             *   Changing the tabout unit to standard output for file
!                 redirection control by the batch file.  Modifying the
!                 open statements to access Environment Variables
!                 instead of Logicals.
!             *   PC Version - this version corresponds to
!                 CADAC_EXEC2_6.FOR on the
!                 VAX for use with MS F32.

!  Aug 93     A problem was discovered with the RANSEED methodology.
!             Since the data is read from the input deck with a real number
!             and VAX real only keeps 7 sig digits, any seeds with more
!             than 7 digits could not be accurately/easily entered.
!             The code was modified to allow the user to enter the most
!             sig. 7 digits and add "01" as the least sig digits.  This
!             generated mods to options 1-3 of the RANSEED card entry.

!  XR 92      Modified the sweep methodology to allow multi-control
!             cards to be used with the sweep cards (ie. type 90, and 5)
!             NOTE: group cards were determined to be inappropriate when
!             used with sweep cards.
!             Test cases for 11 combinations were created and used
!             to test the valid methodology combinations with control
!             cards.
!             Also performed:
!             *  Modified the OPNORO flag and WEII3 variable assignment.
!                Default is OPNORO=0 => rotating earth model;
!             *  Insured that the EXEC code was compatible with EQSORT
!             *  Performed further code cleanup (removed LSTEP from
!                Exec); added more code comments.
!             *  Re-worked RANSEED initialization methodology to allow
!                single trajectories from multi-run cases to be
!                executed without executing the entire run set.
!             *  Discovered a problem with the RANF function on the
!                MicroVax so replaced system RANF with an inline module
!                that is based on the Fortran Intrinsic function RAN.
!                RANF provides uniform random values between (0,1),
!                exclusive of both 0 and 1.
!             *

!  SEU 91-08  Executive code updated.  Final version named CADAC_EXEC1.
!             Code updated documented in ER-TC-SEU 91-08,
!             PROGRAM CADAC: UPGRADE 1
!             Modifications included:
!             *  Futher comments added and code sturcturing performed.
!             *  All output/input files opened using logicals but also
!                have default names when logicals undefined.
!             *  Sweep modules were restructured and commented to allow
!                more flexibility.  Options for the sweep searchings
!                methodology were commented and corrected as needed.
!                Operations were verified.  Card types changed to 19,
!                20 and 21
!             *  A methodology for defining vectors in the C array was
!                implemented as well as the type 7 card for initializing
!                the vector
!             *  Warning messages were added to the modified Euler
!                integration module, AMRK.
!             *  Type 4 card added - comment card.

!  SEU 91-02  Executive received from Dr. Zipfel.  The executive was
!             utilized in the task and the following modifications
!             were performed:
!             *  Structured code elements were substituded for
!                non-structured code elements where applicable
!             *  Comments were added
!             *  Code was broken into modules
!             *  Head.ASC (unit 3) was opened with "readonly" status
!             *  RANSEED variable was added for initialization of random
!                function generator and code to perform the
!                initialization was added to the exec.
!             *  RAYLE, RAYLEI, EXPO and SIGN functions added to type 11
!                and type 3 cards.

!  NOTE:  The cadac executive prints whatever values are in the C location
!         to the trajectory and statistics files.  Any manipulation
!         to the data to produce "interpolated" values at impact must be
!         done by the modules (ie. G4); it is NOT performed here.


!--File Usage------------------------------------------------------------

!  Unit         Logical/file Name  Notes

!   ID_HEAD     HEAD               (I)   Parameter Definition
!   ID_CADIN    CADIN              (I)   Input records (lead cards)
!   ID_IMPACT7  IMPACT7.ASC        (I/O) Scratch.
!   ID_IMPACT10 IMPACT10.ASC       (I/O) Scratch.
!   ID_IMPACT   IMPACT.ASC         (O)   Sweep end results.
!   ID_TRAJBIN  TRAJBIN            (O)   binary trajectory data
!   ID_TRAJASC  TRAJASC            (O)   ascii trajectory data

!   ID_TABOUT   TABOUT             (O)   Output records / scroll to screen
!                                        This was the original VAX version;
!                                        unit 36 was opened with a file named
!                                        "sys$output" when screen display was
!                                        desired.  As this could not be
!                                        duplicated on the PC, the unit
!                                        was changed to *, standard output,
!                                        and the file direction set by the
!                                        command/batch file executing CADAC.
!  ID_STATBIN   STATBIN            (O)  binary tatistical data
!  ID_STATASC   STATASC            (O)  binary tatistical data
!  ID_CSAVE     CSAVE.ASC          (O) Saved state file (optional)

!--Program Format Notes-------------------------------------------------

!  *  WRITE Statements containing the string "%%%" were used for debug
!     purposes only.  These statements are commented out for final releases
!     but were left in.  The information may be useful in later analysis.


!  For compatibility with the utility programs in the CADAC series, the
!  following program format rules must be followed:

!  * Full comment lines must use the C in column 1, NOT the !.  Inline
!    comments are permitted, but NOT on Equivalence or Dimension
!    statements.

!  * Equivalence statements must be consecutive in blocks; NO COMMENT
!    Lines (even blank comment lines) or other statements may be included
!    within the blocks.  The blocks may be divided into the following
!    predefined catagories:
!      INPUT FROM OTHER MODULES
!      INPUT DATA
!      OUTPUT
!      DIAGNOSTICS
!    Blank comment lines are used to indicate the start/end of a block
!    of equivalence statements.


!  This is the main "subroutine" for program cadac.

!--------------------------------------------------------------------

CALL exec


STOP
END PROGRAM cadx
BLOCK DATA aainit

!-------------------------------------------------------------------------

!  This subroutine performs common initialization prior to execution of
!  CADAC

!-------------------------------------------------------------------------

COMMON /ccom/    icf(25), icc(25), icl(25), ca(25),  &
    cl(25), ct0(25), nc, icl2(25)

COMMON /coller/  hol(5)
CHARACTER (LEN=80) :: hol

COMMON /flag1/   initgauss
LOGICAL :: initgauss

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /firsti/ finit
LOGICAL :: finit

COMMON /hcom/    title
CHARACTER (LEN=100) :: title

COMMON /ipsav/   ncards, nhol, jtypes(500), locs(500),  &
    mods(500), va1s(500), va2s(500), mod2(500)

COMMON /ipsavc/  als(3,500), hols(5)
CHARACTER (LEN=80) :: hols chara ter*6 als

COMMON /ipsvsc/  mcris(20,2,4), vals(20,2)

COMMON /ipsvst/  jtsts(20,60), locsts(20,60), modsts(20,60),  &
    va1sts(20,60), va2sts(20,60), mod2st(20,60), ncd(20)

COMMON /ipsvstc/ alsts(20,3,60)
CHARACTER (LEN=6) :: alsts

COMMON /ipsvscc/ mcrisc(20,2,2)
CHARACTER (LEN=6) :: mcrisc

COMMON /ipsvwd/  nwd, wxs(6,50)

COMMON /krun/    jrun, mulrun, igroup

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /oindat/  j16, icd, i16

COMMON /opinit/  iplinit(70), intpinit(70), ninitvar
LOGICAL :: intpinit

COMMON /opinitc/ initlab
CHARACTER (LEN=1) :: initlab(70)*8

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /opflgc/  fmtstring, trace
CHARACTER (LEN=1) :: fmtstring*85, trace(16)*8

COMMON /opplot/  ipladd(70), intplot(70)
LOGICAL :: intplot

COMMON /oppltc/  alable
CHARACTER (LEN=1) :: alable(70)*8

COMMON /opsvar/  iscrol, kloc(16), lprt, iheadp, ints(16)
LOGICAL :: ints

COMMON /optrack/  ipltrack(70), intptrack(70), ntrackvar
LOGICAL :: intptrack

COMMON /optrackc/ tracklab
CHARACTER (LEN=1) :: tracklab(70)*8

COMMON /prev/    tprev, cpprev, ppprev

COMMON /rundat/  irun

COMMON /stage/   loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest

COMMON /stage1/  istage, numstage

COMMON /stagec/  name1(2), name2(2)
CHARACTER (LEN=6) :: name2 chara ter*6 name1

COMMON /winds/   walt(50), wdir(50), wvel(50), rhx(50),  &
    ctmp(50), wpres(50), nwindr, rhw

COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al

COMMON /wsetsc/  mcri(20,2,4), wval(20,2)

COMMON /wsetscc/ mcric(20,2,2)
CHARACTER (LEN=6) :: mcric

COMMON /wsetst/  ncdw(20), jtst(20,60), locst(20,60),  &
    modst(20,60), va1st(20,60), va2st(20,60), m2st(20,60)

COMMON /wsetstc/ alst(20,3,60)
CHARACTER (LEN=6) :: alst

COMMON /wsetwt/  wx(6,50)


!-----------------------------

!     The blank common : C(3510)
!     The C variables defined here are those used by the executive
!     routine;  those c variables assigned to the modules are not
!     defined here as the definition varies depending on the modules
!     used (and written by the user).

!      C(0001) = ERRVAL (Amrk) The maximum integration step error value
!      C(0002) = ERRN   (Amrk) IPL element number of var causing ERRVAL
!      C(0003) = AERR  (Amrk) C element number of var causing ERRVAL
!      C(0004) = PRELOC (Amrk) Previous C element number causing ERRVAL

!      C(0051) = REARTH (Exec) Radius of the Earth in user-sel units
!      C(0052) = CRAD (Exec) Conversion factor. (Degrees / Radians)
!      C(0053) = OPTMET (EXEC) Units of measure 1 = metric; 0 = English
!      C(0054) = AGRAV (Exec) Acceleration due to gravity @ sea level
!      C(0055) = CFTM (Exec) Conversion factor. (Meters / Feet)
!      C(0056) = CKFPS (Exec) Conversion factor. (Knots / ( ft/sec.) )
!      C(0057) = AMU (Exec) Gravitational parameter mu for the Earth (ft^3/sec^2)
!      C(0058) = WEII3 = omega = angular rotation of the earth (rad/sec)
!      C(0059) = OPNORO - Option flag:  0 = rotating earth model
!                WEII3 = 7.2921154E-05;   1 = Non-rotating earth model
!                WEII3 = 0.0

!      C(0090) = RANSEED (Exec) Random function generator initialization.
!                Added under SEU 91-02, this value is used to initialize
!                the system's random number generator.

!      C(1772) = TRCOND (G4) Termin. Condit Codes from right to left.

!      C(1800) = ISWEEP - (Swp) Sweep option flag (0 through 5)
!      C(1801) = CRITNO - (Swp) Critical variable C location
!      C(1802) = CRITVAL - (Swp) Minimum test for critical variable
!      C(1803) = SEARNO - (Swp) Number of binary searche runs (opt 4 and 5)
!      C(1804) = NUMR - (Swp) The number of trajectory runs
!      C(1805) = CRITMAX - (Swp) The maximum test for critical variable
!      C(1811) = ANGLNO - (swp) The C location of the angluar variable
!      C(1812) = ANGMIN - (Swp) The minimum angle value
!      C(1813) = ANGMAX - (Swp) The maximum angle value
!      C(1814) = ANGDEL - (Swp) The Delta angle
!      C(1815) = ANGUNT - (Swp) The units of the input data: rad or deg
!      C(1821) = RANGNO - (Swp) The C location of the range variable
!      C(1822) = RANMIN - (Swp) The minimum range value
!      C(1823) = RANMAX - (Swp) The maximum range value
!      C(1824) = RANDEL - (Swp) The delta range value

!      C(2000) = TIME = Current integration Time in the trajectory.
!      C(2001) = TSTAGE = ? Time when the last stage occurred.
!      C(2003) = PCNT = Time of the next print to TABOUT
!      C(2004) = PPNT = Time of next print to the plot files.
!                (traj.* and stat.*)
!      C(2005) = PPP (Exec) Frequency (time) of writing the plot data.
!      C(2006) = ITAP90 (Exec) A Flag: 0 = No CSAVE.ASC; 1 = trajectory
!                started from data saved to CSAVE.ASC. (Used by D3I)
!      C(2011) = KSTEP (EXEC) Controls flow after an integration step.
!      C(2014) = ITCNT (Exec) Print flag counter
!      C(2015) = CPP (Exec) Frequency (time) of writing TABOUT data
!      C(2016) = PGCNT (Exec) Page counter flag
!      C(2020) = LCONV (Exec) Flag: 0 = start of traj; 2 = Stop calculations
!      C(2127 - 2196) = PMIN(1 - 70)
!      C(2280) = NV = The number of variables in the plot list.
!      C(2285) = NJ   Number of state variables to be integrated
!      C(2361) = NOMOD Number of modules to be called
!      C(2362 - 2460) = XMODNO(1 - 99) Array containing modules numbers to be called
!      C(2461) = NOSUB  Module number to be called
!      C(2462 - 2560) = SUBNO(1 - 99)  Array of module numbers
!      C(2561) = NIP - The number of variables being integrated
!      C(2562 - 2661) = IPL(1 - 100) The locations of the derivative of
!                       the state variable.
!      C(2662) = HMIN  Minimum integration value ?
!      C(2663) = HMAX  Maximum integration value ?
!      C(2664 - 2764) = DER(1 - 101) (Exec) Frequency of integration ?f
!      C(2765 - 2865) = V(1 - 101)
!      C(2866) = ICOOR
!      C(2867-2967) = IPLV(1-100) The location of the state variable;
!                     corresponding to the derivative in the IPL array.


!      DATA C/ 3510 * 0.0 /

!-----------------------------

!      /CCOM/ :
!       ICF(25) - (I) The function type for each defined functions
!       ICC(25) - (I) The combination code for each defined functions
!       ICL(25) - (I) The controlled variable for each defined function
!       CA(25)  - (R) The 1st parameter for each defined function
!       CL(25)  - (R) The 2nd parameter for each defined function
!                 (Modified by C11_process for the GAUSS function)
!       CT0(25) - (R) The time the function is defined. (Set to 0.0
!                 for the GAUSS function)
!          The above array index is from 1 to NC where:
!       NC - (I) Number of forcing functions that have been defined by
!            type 11 input cards.
!       ICL2(I) - (I) The second integer from the input stream =
!                 activated under task SEU 91-02.  May have different
!                 uses depending on the function's definition.

DATA icf/ 25 * 0 /, icc/ 25 * 0 /, icl/ 25 * 0 /, ca/ 25 * 0.0/,  &
    cl/ 25 * 0.0 /, ct0/ 25 * 0.0 /, nc / 0 /, icl2/ 25 * 0 /

!-----------------------------

!     /FLAG1/ :
!        INITGAUSS - (L) Flag for forcing the calculation of random
!                    deviates in the GAUSS module.  .T. = An unused
!                    random deviate is ready for use;  .F. = Need to
!                    calculate another pair.

DATA  initgauss/ .false. /

!-----------------------------

!     /HCOM/ :
!     TITLE = (C100) The input data title written to the TRAJ.* and
!             STAT.* files.

DATA title/ ' '  /

!-----------------------------

!     /IPSAV/ :
!     NCARDS = (I) The number of cards in the stage deck that form the
!              trajectory initialization (ie all cards prior to the
!              first card type 6 or 12).  These cards are saved in
!              special save arrays and reused at the start of each
!              trajectory rerun.
!     NHOL   = (I) Number of header cards entered in the input card deck.
!              (during the trajectory initialization)
!     These arrays are storage arrays that contain the data from the
!     input initialization cards.  The initialization cards are the input
!     cards until the first card type 6 or 12 is reached.  The main card
!     data is stored in these arrays and reloaded at the beginning of
!     each trajectory in multi trajectory run cases.
!     JTYPES(500) - (I) Contains the first integer (card types) from
!                   the input cards.
!     LOCS(500)   - (I) Contains the second integer from the input card.
!     MODS(500)   - (I) Contains the third integer from the input card.
!     VA1S(500)   - (R) Contains the first real from the input card.
!     VA2S(500)   - (R) Contains the second real from the input card.
!     MOD2(500)   - (I) Contains a fourth integer from the input card.
!     For the above arrays, the index is the card number from 1 to
!     NCARDS.

DATA ncards/ 0 /, nhol/ 0 /, jtypes/ 500 * 0 /, locs/ 500 * 0 /,  &
    mods/ 500 * 0 /,  va1s/ 500 * 0.0 /, va2s/ 500 * 0.0 /, mod2/ 500 * 0 /


!-----------------------------

!     /IPSAVC/
!     These arrays are storage arrays that contain the CHARACTER data from
!     the initialization cards.  The initialization cards are the input
!     cards until the first card type 6 or 12 is reached.  The main card
!     data is stored in these arrays and reloaded at the beginning of
!     each trajectory in multi trajectory run cases.
!     ALS(3,500) - (C6) Storage array containing the 3 sets of
!                  character data entered with the input initialization
!                  cards.  Index = 1, NCARDS
!     HOLS(5)    - (C80) Storage array containing the character data
!                  entered with a type 9 card with the initialization
!                  cards. (Index = 1, NHOLS )

DATA als/ 1500 * '      ' /, ( hols(j), j=1,5)/ 5 * ' '  /

!-----------------------------

!     /IPSVSC/ :
!     These arrays are storage arrays that contain the data from
!     the type 10 (Stage Criteria) cards within the initialization
!     card set. The initialization cards are the input cards until the
!     first card type 6 or 12 is reached.  The card data is stored in
!     these arrays and reloaded at the beginning of each trajectory in
!     multi trajectory run cases.   MAXIMUM NUMBER OF STAGES = 20
!     MCRIS(20,2,4) - (I) Contains integer data from the type 10 cards.
!     VALS(20,2)    - (R) Contains real data from the type 10 cards.

DATA mcris/ 160 * 0 /, vals/ 40 * 0.0 /

!-----------------------------

!     /IPSVSCC/ :
!     This arrays is a storage array that contains the CHARACTER data
!     from the type 10 (Stage Criteria) cards within the initialization
!     card set. The initialization cards are the input cards until the
!     first card type 6 or 12 is reached.  The card data is stored in
!     these array and reloaded at the beginning of each trajectory in
!     multi trajectory run cases.  MAXIMUM NUMBER OF STAGES = 20
!     MCRISC(20,2,2) - (C6) Storage array containing the 2 sets of
!                      character data for the type 10 cards from the
!                      initialization deck.
DATA mcrisc/ 80 * '      ' /

!-----------------------------

!     /IPSVST/ :
!     These arrays are storage arrays that contain the data from
!     the STage cards within the initialization card set. The
!     initialization cards are the input cards until the first card
!     type 6 or 12 is reached.  These cards are executed at the beginning
!     of a trajectory for each multirun/montecarlo run. The data is
!     transferred from these arrays to the working set of arrays at the
!     begining of each run.  Any data entered by a type 12 card is then
!     applied to the cards.  N = 1-20 = stage number; NN = 1-60 = card
!     number for the set of cards in stage N = 1 to NCD( N )
!     JTSTS(20,60)  - (I) First integer from card data = cardtype.
!     LOCSTS(20,60) - (I) Second integer from the card data.
!     MODSTS(20,60) - (I) Third integer from the card data.
!     VA1STS(20,60) - (R) First real value from the card input data.
!     VA2STS(20,60) - (R) Second real value from the card input data.
!     MOD2ST(20,60) - (I) Fourth integer from the card data.
!     NCD(20)       - (I) Number of cards for stage N following the type
!                      16 card until a type 6, 10 or 12 card occurrs.
!                      This is the max NN values for the above storage
!                      arrays.

DATA jtsts/ 1200 * 0 /, locsts/ 1200* 0 /, modsts/ 1200* 0 /,  &
    va1sts/ 1200* 0.0 /, va2sts/ 1200 * 0.0/, mod2st/ 1200 * 0 /, ncd/ 20 * 0 /

!-----------------------------

!     /IPSVSTC/ :
!     These arrays are storage arrays that contain the CHARACTER data
!     from the STage cards within the initialization card set. The
!     initialization cards are the input cards until the first card
!     type 6 or 12 is reached.  These cards are executed at the beginning
!     of a trajectory for each multirun/montecarlo run. The data is
!     transferred from these arrays to the working set of arrays at the
!     begining of each run.  Any data entered by a type 12 card is then
!     applied to the cards.  N = 1-20 = stage number; NN = 1-60 = card
!     number for the set of cards in stage N = 1 to NCD( N )
!     ALSTS(20,3,60) - (C6) A storage array containing the character
!              data from the input cards.  This arrays belongs with the
!              storage set of arrays : JTSTS, LOCSTS, MODSTS, etc, found in
!              common /IPSVST/. See these variable definitions for more
!              information.

DATA alsts/ 3600 * ' ' /

!-----------------------------

!     /IPSVWD/ :
!     This array is a storage array that contains the WEATHER data
!     within the initialization card set. The initialization cards are
!     the input cards until the first card type 6 or 12 is reached.
!     These cards are executed at the beginning of a trajectory for
!     each multirun/montecarlo run. The data is transferred from these
!     arrays to the working set of arrays at the begining of each run.
!     NWD - (I) The number of atmospheric data sets read into the
!                 WXS array.
!     WXS(6,50) - (R) Contains the atmospheric data as read from the
!                input cards.  WXS(I,J) : I => 1 = Altitude, 2 =
!                Wind Direction, 3 = Wind Velocity, 4 = Density,
!                5 = Temperature, 6 = Pressure
!                Up to J=50 sets of atmospheric data may be entered.

DATA nwd/ 0 /, wxs/ 300 * 0.0 /


!-----------------------------

!     /KRUN/ :
!     JRUN   - (I) Run number/counter for the multi-run cases.
!     MULRUN - (I) Flag that indicates if case is a multi-run case or
!              not:  0 = NOT multi-run case;  N = Number of runs in
!              the Multi-run case.
!     IGROUP - (I) The group number/counter

DATA jrun/ 1 /, mulrun/ 0 /, igroup/ 1 /

!-----------------------------

!      /NAD/   :
!      IBEEN,
!      IBEGIN - (I) The Stage number where a save of C to tape 90
!               occurred.
!      ICARD  - (I) The card number where a save of C to tape 90
!               occurred.
!      ISAVE  - (I) Flag: indicates that the C array has been saved to tape
!               90

DATA ibeen/ 0 /, ibegin/ 0 /, icard/ 0 /, isave/ 0 /

!-----------------------------

!     /OINDAT/  :
!      J16  - (I) FLAG: 0 = Pull card data from the main trajectory
!             arrays;  1 = Pull card data from the stage data arrays.
!      ICD  - (I) Counter.  The card number for the main trajectory
!             arrays, of the card currently being processed by OINPT1
!      I16  - (I) Counter.  The card number for the stage arrays, of the
!             card currently being processed by OINPT1.

DATA j16/ 0 /, icd/ 0 /, i16/ 0 /

!-----------------------------

!     /OPFLAG/ :
!     INTMSG    = (L) T= Print integration error messages to both
!                        sys$output and tabular output (?).  F= supress
!                        integration error message displays.
!     STGMSGOUT = (L) T= Print stage messages to Tabout file;
!                     F= supress staging messages.
!     INECHO    = (L) T= Echo the input to the output file;
!                     F= supress the echo of the input deck.
!     XSWEEP    = (L) T= Execution is a SWEEP run
!                     F= Execution is not a SWEEP run

DATA intmsg/ .false. /, stgmsgout/ .false. /, inecho/ .true. /  &
    xsweep/ .false. /

!-----------------------------
!     /FILEFLG/

!     TRAJBIN   = (L) T= create binary trajectory file
!                     F= don't create binary trajectory file
!     TRAJASC   = (L) T= create ascii trajectory file
!                     F= don't create ascii trajectory file
!     STATBIN   = (L) T= create binary statistics file
!                     F= don't create binary statistics file
!     STATASC   = (L) T= create ascii statistics file
!                     F= don't create ascii statistics file
!     TABOUT    = (L) T= create output to TABOUT.ASC
!                     F= write output to screen
!     RANVAR    = (L) T= Print type 3 and type 11 random value
!                        assignments of variables to unit 37 = RANVAR.ASC
!     INITASC   = (L) T= create ascii RT initializtion file
!                     F= don't create ascii RT initializtion file
!     INITBIN   = (L) T= create binary RT initializtion file
!                     F= don't create binary RT initializtion file
!     TRACKASC  = (L) T= create ascii RT track data file
!                     F= don't create ascii RT track data file
!     TRACKBIN  = (L) T= create binary RT track data file
!                     F= don't create binary RT track data file
DATA trajbin/.false./, trajasc/.false./, statbin/.false./,  &
    statasc/.false./, tabout/.false./,  ranvar/ .false. /,  &
    initasc/.false./, initbin/.false./, trackasc/.false./, trackbin/.false./

!-----------------------------
!      /FILEIDS/
!      ID_CADIN    (I) - file id for input file CADIN.ASC
!      ID_HEAD     (I) - file id for input head.asc
!      ID_CSAVE    (I) - file id for saved states file
!      ID_TRAJBIN  (I) - file id for binary trajectory file
!      ID_TRAJASC  (I) - file id for ascii trajectory file
!      ID_STATBIN  (I) - file id for binary statistics file
!      ID_STATASC  (I) - file id for ascii statistics file
!      ID_TABOUT   (I) - file id for tabular output file
!      ID_RANVAR   (I) - file id for random variable file
!      ID_INITASC  (I) - file id for ascii RT CADAC initialization file
!      ID_INITBIN  (I) - file id for binary RT CADAC initialization file
!      ID_TRACKASC (I) - file id for ascii RT CADAC track data file
!      ID_TRACKBIN (I) - file id for binary RT CADAC track data file


DATA id_cadin/35/,   id_head/ 3/ ,   id_csave/90/, id_tabout/6/
DATA id_trajbin/11/, id_trajasc/12/
DATA id_statbin/44/, id_statasc/45/
DATA id_ranvar/37/
DATA id_impact/22/,   id_impact7/ 7/,  id_impact10/10/
DATA id_initasc/50/, id_initbin/51/
DATA id_trackasc/60/, id_trackbin/61/

!-----------------------------

!     /OPFLGC/ :
!     FMTSTRING  = (C) Contains the format to use when printing the
!                  scroll variables.
!     TRACE(16)  = (C8) Scroll variable parameter name (acronym).

DATA fmtstring/ ' ' /,  trace/ 16 * ' ' /

!-----------------------------

!     /OPPLOT/:
!     IPLADD(70) = (I) Contains the list of C common locations to be
!                  printed to the plot data file. (TRAJ.*/STAT.*)
!     INTPLOT(70) = (L) Flag indicating if the plot variable is a real
!                  variable (.false.) or an integer variable (.true.)

DATA ipladd/ 70 * 0 /, intplot/ 70 * .false. /


!-----------------------------

!     /OPPLTC/:
!     ALABLE(70) = (C8) Contains the aronyms of the C common locations
!                  that are to be printed to the plot data file.
!                  (TRAJ.*/STAT.*)

DATA  alable/ 70 * '        ' /

!-----------------------------

!     /OPINIT/:
!     IPLINIT(70)  = (I) Contains the list of C common locations to be
!                    printed to the RT initialization file. (INIT.ASC/BIN)
!     INTPINIT(70) = (L) Flag indicating if the plot variable is a real
!                    variable (.false.) or an integer variable (.true.)
!     NINITVAR     = (I) The number of variables to be plotted on the
!                    RT initialization data file

DATA iplinit/ 70 * 0 /, intpinit/ 70 * .false. /


!-----------------------------

!     /OPINITC/:
!     INITLAB(70) = (C8) Contains the aronyms of the C common locations
!                   that are to be printed to the RT initialization file.
!                   (INIT.ASC/BIN)

DATA  initlab/ 70 * '        ' /


!-----------------------------

!     /FIRSTI/:
!     FINIT = (L) Flag inidicating to write to INIT.ASC file the first time
!                 the C array is loaded with the intialization data

DATA finit/.true./


!-----------------------------

!     /OPSVAR/ :
!     ISCROL   = (I) Flag: 0 = NO scroll variables; 1 = Scroll
!                variables defined, display them on the screen/output.
!     KLOC(16) = (I) C element location of the scroll variables.
!     LPRT     = (I) Number of scroll variables.
!     IHEADP   = (I) Counts the number of lines printed to output
!                under the SCROLL option.  The counter used for
!                displaying the header information every 10 data
!                lines.
!     INTS(16) = (L) Integer flag indicating whether the scroll variable
!                is a real number (= 0 ) or an integer number ( = 1)

DATA iscrol/ 0 /, kloc/ 16 * 0 /, lprt/ 0 /, iheadp/ 0 /, ints/ 16 * .false. /

!-----------------------------

!     /OPTRACK/:
!     IPLTRACK(70)  = (I) Contains the list of C common locations to be
!                     printed to the RT track data file. (TRACK.ASC/BIN)
!     INTPTRACK(70) = (L) Flag indicating if the plot variable is a real
!                     variable (.false.) or an integer variable (.true.)
!     NTRACKVAR     = (I) The number of variables to be plotted on the
!                     RT track data file

DATA ipltrack/ 70 * 0 /, intptrack/ 70 * .false. /


!-----------------------------

!     /OPTRACKC/:
!     TRACKLAB(70) = (C8) Contains the aronyms of the C common locations
!                    that are to be printed to the RT track data file.
!                    (TRACK.ASC/BIN)

DATA  tracklab/ 70 * '        ' /

!-----------------------------


!      /PREV/ :
!      TPREV  - (R) The time the previous stage occurred.
!      CPPREV - (R) The saved tabular print interval.  Used to detect
!               whether the CPP value has been modified or not.
!      PPPREV - (R) The saved plot print interval.  Used to detect
!               whether the PPP value has been modified or not.

DATA tprev/ 0.0 /, cpprev/ 0.0 /, ppprev/ 0.0 /

!-----------------------------

!      /RUNDAT/  :
!      IRUN  - (I) Counter for the runs executed in the sweep methodology.

DATA irun/ 0 /


!-----------------------------

!      /STAGE/  :
!      LOC(2)   - (I) C element location of the staging variable
!      INCRS(2) - (I) Flag to determine relationship of staging variable
!                 value to staging criteria.  0 : <=  ;  1 : >=
!      VAL(2)   - (R) The (KODE=0) the staging criteria; (KODE>0) the C
!                 element containing the staging criteria; (KODE<0) an
!                 amount added to the original value of the LOC variable
!                 (prior to the stage) giving the staging criteria.
!      UNITS(2) - (R) Unused at this point ?
!      KODE(2)  - (I) Flag to determine how the VAL data is to be used
!      TEST(2)  - (R) (KODE<=0) The staging test criteria
!      LOCT(2)  - (I) (Kode>0) The C element containing the staging test
!                 criteria
!         For the above arrays, the index = 1, NTEST, the number of
!         staging tests.
!      NTEST    - (I) The number of staging tests (Max=2)

!      DATA LOC(2), INCRS(2), VAL(2), UNITS(2), KODE(2),
!     1                TEST(2), LOCT(2), NTEST

!-----------------------------

!      /STAGE1/ :
!      ISTAGE   - (I) Flag: 0 = Start of the trajectory;  16 = Execute
!                 until the stage criteria is met;  6 = Execute until end
!                 of trajectory.
!      NUMSTAGE - (I) The number of the stage currently being processed.

DATA istage/ 0 /, numstage/ 0 /

!-----------------------------

!      /STAGEC/ :
!      NAME1(2) - (C6) The input variable name of the staging variable
!      NAME2(2) - (C6) (Kode>0) The input variable name of the variable
!                 whose value is to be used as the staging criteria.

!      DATA NAME1(2), NAME2(2)

!-----------------------------

!     /WINDS/
!     WALT(50)
!     WDIR(50)
!     WVEL(50)
!     RHX(50)
!     CTMP(50)
!     WPRES(50) -
!     NWINDR -    (I) Dummy variable to keep alignment with this common
!                 block in the modules.
!     RHW


!-----------------------------

!     /WSET/ :
!      These arrays contain the working set of the lead trajectory
!      cards.  They are initialized by being set to the saved
!      initialization arrays (contain the original initialization cards
!      read from input), then the cards for the current trajectory group
!      are added or modify this set accordingly.
!     NCARD - (I) The number of cards in the working set.  Initialized
!              to the number of cards in the saved set (ncards), then
!              incremented for each card pertaining to the current
!              trajectory.
!     JTYPE(J) - (I)
!     LOCA(J)  - (I)   -- See the IPSAV common variables for definitions
!     MOE(J)   - (I)
!     VA1(J)   - (R)
!     VA2(J)   - (R)
!     M2(J)    - (I)
!      For the above variables, J = 1, NCARD with a maximum of 500.

DATA ncard/ 0 /, jtype/ 500 * 0 /, loca/ 500 * 0 /,  &
    moe/ 500 * 0 /, va1/ 500 * 0.0 /, va2/ 500 * 0.0 /, m2/ 500 * 0 /

!-----------------------------

!     /WSETC/ :
!      These arrays contain the working set CHARACTER data for the
!      lead trajectory cards.  They are initialized by being set to
!      the saved initialization arrays (contain the original
!      initialization cards read from input), then the cards for the
!      current trajectory group are added or modify this set accordingly.
!      See common /IPSAVC/ for definitions.
!      AL(3,500)     - (C6)
!      HOLL(5)       - (C80)

DATA al/ 1500 * ' ' /, holl/ 5 * ' ' /

!-----------------------------

!     /WSETSC/  :
!     These arrays contain the working set trajectory data from
!     the type 10 (Stage Criteria) cards.
!     MCRI(20,2,4) - (I) Contains integer data from the type 10 cards.
!     WVALS(20,2)    - (R) Contains real data from the type 10 cards.

DATA mcri/ 160 * 0 /, wval/ 40 * 0.0 /

!-----------------------------

!     /WSETSCC/ :
!      MCRIC(20,2,2) - (C) This array contains the working set
!                      trajectory CHARACTER data from the type 10

DATA mcric/ 80 * ' ' /

!-----------------------------

!      /WSETST/ :
!     These arrays are the working arrays that contain the data from
!     the STage cards.  See common /IPSVST/ for definitions.
!     NCDW(20) - (I)
!     JTST(20,60)  - (I)
!     LOCST(20,60) - (I)
!     MODST(20,60) - (I)
!     VA1ST(20,60) - (R)
!     VA2ST(20,60) - (R)
!     M2ST(20,60)  - (I)

DATA jtst/ 1200 * 0 /, locst/ 1200 * 0 /, modst/ 1200 * 0 /,  &
    va1st/ 1200 * 0.0 /, va2st/ 1200 * 0.0/, ncdw/ 20 * 0 /, m2st/ 1200 * 0.0 /

!-----------------------------

!     /WSETSTC/ :
!     This array is the working set array containing the CHARACTER data
!     from the STage cards.  N = 1-20 = stage number; NN = 1-60 = card
!     number for the set of cards in stage N = 1 to NCD( N )
!     ALST(20,3,60) - (C6) A storage array containing the character
!              data from the input cards.  This arrays belongs with the
!              storage set of arrays : JTST, LOCST, MODST, etc, found in
!              common /WSETST/ See these variable definitions for more
!              information.

DATA alst/ 3600 * ' ' /

!-----------------------------

!     /WSETWT/  : WX(6,50)
!     This array is a working array that contains the WEATHER data.
!     WX(6,50) - (R) Contains the atmospheric data as read from the
!                input cards.  WX(I,J) : I => 1 = Altitude, 2 =
!                Wind Direction, 3 = Wind Velocity, 4 = Density,
!                5 = Temperature, 6 = Pressure
!                Up to J=50 sets of atmospheric data may be entered.

DATA wx/ 300 * 0.0 /

!-----------------------------

END
!      INTEGER*4 FUNCTION HANDL( SIGARGS, MECHARGS )

!-------------------------------------------------------------------------

!  The "subroutine" handl generates the Dump.dat file when an error
!  (math, overflow, etc) is caused by the program/module.

!--Argument Definitions-------------------------------------------------

!  SIGARGS(2)  - (I) Input.
!  MECHARGS(5) - (I) Input.

!-------------------------------------------------------------------------

!      COMMON C(3510)

!      DIMENSION   IC(3510)
!      EQUIVALENCE (C(0001), IC(0001) )

!      INTEGER*4 SIGARGS(2), MECHARGS(5)

!      INCLUDE '($SSDEF)'


!      OPEN( 89, FILE='DUMP.BIN', STATUS='NEW', FORM='BINARY',
!     1           RECORDTYPE='SEGMENTED', ACCESS='SEQUENTIAL',
!     2           ORGANIZATION='SEQUENTIAL' )

!      WRITE(89) C, IC
!      CLOSE (89)

!      WRITE(ID_TABOUT,*)
!      WRITE(ID_TABOUT,*) ' **** WRITE ALL C-LOCATIONS  ON DUMP.DAT ****'
!      WRITE(ID_TABOUT,*) '  USE [ZIPFELP.CADAC]DUMP.EXE TO EXAMINE'
!      WRITE(ID_TABOUT,*) ' THEIR CONTENTS AT THE FATAL ERROR.'
!      WRITE(ID_TABOUT,*)

!      RETURN
!      END

SUBROUTINE amrk

!-------------------------------------------------------------------------

!  Modified EULER numerical integration algorithm:
!   Given:
!           Y' = F( t, y )
!   Estimate Y = F( t, y ) by:
!           w(i+1) =  w(i)  +  h/2(  f[ t(i), w(i) ]
!                              +  f[ t(i+1), w(i) + h f[ t(i), w(i) ] ] )
!   given w(o) = initial value of y.


!-------------------------------------------------------------------------


COMMON  c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

DIMENSION  der(101), ipl(100), v(101)

EQUIVALENCE (c(0001), errval )
EQUIVALENCE (c(0002), errn   )
EQUIVALENCE (c(0003), aerr   )
EQUIVALENCE (c(0004), preloc )
EQUIVALENCE (c(2001), tstage )
EQUIVALENCE (c(2285), nj     )
EQUIVALENCE (c(2664), der(1) )
EQUIVALENCE (c(2562), ipl(1) )
EQUIVALENCE (c(2765), v(1)   )
EQUIVALENCE (c(2866), icoor )

DIMENSION pred(100), OLD(100)
DATA      OLD/ 100 * 0.0 /


!---  Improved Euler method of numerical integration.

!---  Calculate the prediction value:
!         f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]

!     Set the flag to indicate that the predictor loop is being
!     performed.

icoor = 0

DO i = 1, nj
  
!        Load the array with the initial values: f( t(i), w(i) )
  
  OLD(i)  = der(i+1)
  
!        Calculate:  w(i+1) + h f( t(i), w(i) )
  
  v(i+1)  = v(i+1) + OLD(i) * der(1)
  
!        Save these values:  PRED = w(i+1) + h f( t(i), w(i) )
  
  pred(i) = v(i+1)
END DO

!     Increment time to t(i+1):

v(1) = v(1) + der(1)

!     Calculate:  f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]

CALL auxsub

!     Note:  the AUXSUB loads the C array from the V data and
!     reloads the DER array at the end of the module execution.
!     V NOW contains the value: w(i+1) + h f( t(i), w(i) ) after
!            calculations of the function.
!     DER NOW contains the the value:
!             f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]


!---  Corrector loop.

!     Set the flag to indicate the correction loop is being performed.

icoor = 1

!     Compute half the time step:

halfd = der(1) / 2.0

!     Calculate the new value.  This APPEARS to have a sign error in the
!     equation.  However this is just due to the definitions of the
!     variables.  Remember - trying to calculate the following:
!           w(i+1) =  w(i)  +  h/2(  f[ t(1), w(i) ]
!                              +  f[ t(i+1), w(i) + h f[ t(i), w(i) ] ] )
!     At this point in the calculations:
!        V(i)   = w(i+1) + h f( t(i), w(i) )
!        Der(i) = f[  t(i+1),  w(i+1) + hf( t(i), w(i) )  ]
!        Old(i) = f( t(i), w(i) )
!     Substituting in values:
!     V(i+1) = { w(i+1) + h f( t(i), w(i) ) }
!              + h/2 {  f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]
!                       - f( t(i), w(i) ) }
!     Distribute h/2 and rearrange terms:
!     V(i+1) = w(i+1) + h f( t(i), w(i) ) - (h/2) f( t(i), w(i) )
!                    + (h/2) f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]
!     Subtracting  f( t(i), w(i) ) terms:
!     V(i+1) = w(i+1) + (h/2) f( t(i), w(i) )
!                    + (h/2) f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]
!     Factoring h/2 from both terms giving :
!     V(i+1) = w(i+1) + (h/2) {  f( t(i), w(i) )
!                    + f[ t(i+1), w(i+1) + hf( t(i), w(i) ) ]  }

DO i = 1, nj
  v(i+1) = v(i+1) + (der(i+1) - OLD(i)) * halfd
END DO


!---  Perform some integration error checking:

IF( tstage >= 0.1 ) THEN
  
!         Find the integration variable that caused the greatest
!         error for THIS TIME STEP.
  
!         Initialize the error value.
  
  errval = 0
  
  
  DO i = 1, nj
    
!            Skip the elements assigned to the C4 module.
    
    IF( .NOT. ( ipl(i) >= 1100 .AND.  ipl(i) < 1200 ) ) THEN
      
!                Remember:
!                    PRED = w(i+1) + h f( t(i), w(i) ) PRIOR to
!                           calculating the derivative function value.
!                    V(i) = w(i+1) + h f( t(i), w(i) ) AFTER the
!                           calculations of the derivative.
      
      den = AMAX1( ABS( v(i+1) + pred(i) ), 2.0 )
      ERR = ABS( 2.0 * ( v(i+1) - pred(i) ) / den )
      
      
      IF(  ERR  >= errval  ) THEN
        
!                    The error value is bigger than the previous error
!                    Update the error parameters.
        
        errn   = i         ! Integration element number
        aerr   = ipl( i )  ! C element number
        errval = ERR       ! error value
      END IF
    END IF
    
  END DO
  
  
  IF( aerr == preloc ) THEN
    
!             Previous variable producing the max error value.
!             Increment the error counter.
    
    ierrcount = ierrcount + 1
    
    IF( intmsg  .AND.  ierrcount > 100  .AND. preloc /= premessage     ) THEN
      
!                 The variable has been the maximum error for over 100
!                 integration steps AND the message has not been
!                 previously displayed for this variable AND the
!                 integration messages are to be displayed.
      
      WRITE(id_tabout,500) aerr, errval
      IF( tabout ) WRITE(6,500) aerr, errval
      500             FORMAT( 1X, '*** INTEGRATION WARNING ***' /,  &
          4X, 'C LOCATION: ', f7.0, ' generated an', ' error of ', g15.6 )
      
      ierrcount = 1
      
!                 Save the variable number the message was printed for.
      
      premessage = preloc
      
    END IF
    
  ELSE
    
!             New variable causing the max error.
    
    preloc = aerr
    ierrcount = 1
    
  END IF
  
  
END IF


!     Compute the function value:

CALL auxsub

RETURN
END SUBROUTINE amrk

SUBROUTINE auxi

!-------------------------------------------------------------------------

!     This module controls the execution of the initialization modules
!     for the MODULES entered on the type 2 input cards.

!-------------------------------------------------------------------------

LOGICAL :: stgemet

COMMON      c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

DIMENSION   xmodno(99)

EQUIVALENCE (c(2361), nomod )
EQUIVALENCE (c(2362), xmodno(1) )
EQUIVALENCE (c(2561), nip )

nip = 1

!---  Call SWEEP Methodologies
CALL sweepi


DO  i = 1, nomod
  
  
  l = xmodno(i)
  
  GO TO ( 1000, 100, 110, 120, 130, 140, 150, 160,  &
      170, 180, 190, 200, 200, 200, 200, 200,  &
      210, 220, 230, 240, 250, 260, 270, 280,  &
      290, 300, 310, 320, 330, 340, 350, 360 ), l
  
  WRITE(id_tabout,*) '  GOTOER IN AUXI, L  = ',l
  
  
  100    CALL a1i
  CYCLE
  
  110    CALL a2i
  CYCLE
  
  120    CALL a3i
  CYCLE
  
  130    CALL a4i
  CYCLE
  
  140    CALL a5i
  CYCLE
  
  150    CALL c1i
  CYCLE
  
  160    CALL c2i
  CYCLE
  
  170    CALL c3i
  CYCLE
  
  180    CALL c4i
  CYCLE
  
  190    CALL c5i
  CYCLE
  
  200    CONTINUE
  CYCLE
  
  210    CALL d1i
  CYCLE
  
  220    CALL d2i
  CYCLE
  
  230    CALL d3i
  CYCLE
  
  240    CALL d4i
  CYCLE
  
  250    CALL d5i
  CYCLE
  
  260    CONTINUE
  CALL g1i
  CYCLE
  
  270    CALL g2i
  CYCLE
  
  280    CALL g3i
  CYCLE
  
  290    CALL g4i
  CYCLE
  
  300    CALL g5i
  CYCLE
  
  310    CONTINUE
  CYCLE
  
  320    CALL s1i
  CYCLE
  
  330    CALL s2i
  CYCLE
  
  340    CALL s3i
  CYCLE
  
  350    CALL s4i
  CYCLE
  
  360    CALL s5i
  CYCLE
  
END DO


!---  Run the initialization module for G4. (G4 is not a module but
!     determines the end of run.  It is executed in STGE3 and not included
!     in the input list of modules to be executed, therefore the G4I
!     module is not executed so this forces the execution)

CALL g4i


!---  Check to see if output needs to be generated.  Call the
!     output controlling module

stgemet = .false.        ! Output not called after stage met.
CALL oupt3( stgemet )


RETURN
END SUBROUTINE auxi

SUBROUTINE auxsub

!-------------------------------------------------------------------------

!  This module controls the calling of the modules selected by the type
!  2 input cards.

!-------------------------------------------------------------------------

!  NUMSUB - (I) The number of the module entered on the type 2 card.

!-------------------------------------------------------------------------


COMMON        c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /prev/ tprev, cpprev, ppprev

COMMON /krun/  jrun, mulrun, igroup

DIMENSION   xmodno(99)

EQUIVALENCE (c(2000), time      )
EQUIVALENCE (c(2361), nomod     )
EQUIVALENCE (c(2362), xmodno(1) )
EQUIVALENCE (c(2561), nip       )
EQUIVALENCE (c(2020), lconv     )
EQUIVALENCE (c(2001), tstage    )

EQUIVALENCE (c(2866), icoor )

!     Load the C array from the current results of the integration
!     module

CALL ld_carray( nip )


!---  Compute time in stage.

tstage = time - tprev

!---  Evaluate all type 11 variables NOT associated with a user module.
!     These values will be used in the subsequent Module calls.

CALL cntrol( 1, 1 )


!     Call the modules selected by the type 2 cards.

DO  i = 1, nomod
  
!        Lconv = 2 = end of trajectory has been reached; exit this module.
  
  IF( lconv >= 2 ) THEN
    
!           Reset the ISAVE flag is at the end of a set of group runs
    
    IF( jrun >= mulrun ) isave = 0
    
    RETURN
    
  END IF
  
  numsub = xmodno(i)
  
  GO TO ( 500, 110, 120, 130, 140, 150, 160, 170, 180,  &
      190, 200, 210, 210, 210, 210, 210, 220, 230,  &
      240, 250, 260, 270, 280, 290, 300, 310, 320,  &
      330, 340, 350, 360, 380 ),  numsub
  
  WRITE(id_tabout,*) '  GOTOER IN AUXSUB, NUMSUB = ', numsub
  
  
  110    CALL a1
  GO TO 500
  
  120    CALL a2
  GO TO 500
  
  130    CALL a3
  GO TO 500
  
  140    CALL a4
  GO TO 500
  
  150    CALL a5
  GO TO 500
  
  160    CALL c1
  GO TO 500
  
  170    CALL c2
  GO TO 500
  
  180    CALL c3
  GO TO 500
  
  190    CALL c4
  GO TO 500
  
  200    CALL c5
  GO TO 500
  
  210    CONTINUE
  GO TO 500
  
  220    CALL d1
  GO TO 500
  
  230    CALL d2
  GO TO 500
  
  240    CALL d3
  GO TO 500
  
  250    CALL d4
  GO TO 500
  
  260    CALL d5
  GO TO 500
  
  270    CALL g1
  GO TO 500
  
  280    CALL g2
  GO TO 500
  
  290    CALL g3
  GO TO 500
  
  300    CALL g4
  GO TO 500
  
  310    CALL g5
  GO TO 500
  
  320    CONTINUE
  GO TO 500
  
  330    CALL s1
  GO TO 500
  
  340    CALL s2
  GO TO 500
  
  350    CALL s3
  GO TO 500
  
  360    CALL s4
  GO TO 500
  
  380    CALL s5
  GO TO 500
  
  500 CALL cntrol( 0, numsub )
END DO

!     NOTE:  The above call evaluates the type 11 functions associated
!     with particular Modules.  These values will be used the NEXT time
!     the Modules are called;  These new values are also the ones that
!     are output on the tabular/plot data files;  the data precedes it's
!     usage on output.


!     Load the integration arrays from the C array:

CALL ld_deriv( nip )

RETURN
END SUBROUTINE auxsub

SUBROUTINE c1_process( ir2, iswth )

!-------------------------------------------------------------------------

!    Card type 1 : Module Selection: OUPT3 and STGE3
!    These cards select the modules to be executed AFTER EACH
!    INTEGRATION STEP.  The selected module numbers are loaded into the
!    array SUBNO for use in the module that actually calls each module.

!    Only two modules are currently available in this version
!    of CADAC:  #3 = OUPT3 and #4 = STGE3.

!    Card Format:
!      Column       Description
!       1-2         (I) "01" = Card type number
!       4-9         (C) Sub-module Name (Not used)
!       25          (I) Sub-module Number

!--Argument List Definitions--------------------------------------------

!  IR2   - (I) Input. The second integer input on the card = submodule
!          number.
!  ISWTH - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------


!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(OUT)                     :: iswth
COMMON  c(3510)

DIMENSION   subno(99)

EQUIVALENCE (c(2461), nosub    )
EQUIVALENCE (c(2462), subno(1)  )


icardtype = 1

!    Check to insure that there is room in the arrays and the
!    maximum number of modules has not yet been reached.

IF( nosub == 99 ) THEN
  iswth = 1
  CALL oin1_emsg( icardtype )
  RETURN
END IF

!     Check for an invalid module number.

IF( ir2 <= 0  .OR.  ir2 > 9 ) THEN
  iswth = 1
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!     Add the module number to the list to be executed.

nosub = nosub + 1
subno( nosub ) = ir2


RETURN
END SUBROUTINE c1_process

SUBROUTINE c2_process( ir2, iswth )

!-------------------------------------------------------------------------

!  Card type 2:  Module selection cards.  These cards contain the
!  list of module numbers to be executed, in the order of execution.
!  Load the module numbers into the array for selection by the module
!  that controls module exeuction.

!    Card Format:
!      Column       Description
!        1-2         (I) "02" = Card type number
!        3-20        (C) Submodule Name (Not used)
!       21-25        (I) Sub-module  Number

!--Argument List Definitions--------------------------------------------

!  IR2   - (I) Input. The second integer input on the card = sub-module
!          number.
!  ISWTH - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------

!  ICARDTYPE - (I) The card type that is currently being processed.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(OUT)                     :: iswth
COMMON  c(3510)

DIMENSION   xmodno(99)

EQUIVALENCE (c(2361), nomod    )
EQUIVALENCE (c(2362), xmodno(1) )

!     NOMOD = The number of modules to be executed (as input by user)
!     XMODNO(1) = The number of the module to be executed.


icardtype = 2

!     Check to see if the max. number of modules has been reached.

IF( nomod == 98 ) THEN
  iswth = 2
  CALL oin1_emsg( icardtype )
  RETURN
END IF

!     Check for an invalid module number

IF( ir2 <= 0  .OR.  ir2 > 37 ) THEN
  iswth = 2
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!     Add the module to the list.

nomod = nomod + 1
xmodno( nomod ) = ir2


RETURN
END SUBROUTINE c2_process

SUBROUTINE c7_process( ir2, mode, vr, nstage, iswth )

!-------------------------------------------------------------------------

!  Card type 7 : VECTOR Variable initialization Card.  These cards
!  allow values to be assigned to VECTORS in the C common variable.

!    Card Format:
!      Column       Description
!        1-2         (I) "07" = Card type number
!        3-8         (C) Variable Name (Documentation use only)
!        9-14        (C)
!       21-25        (I) Variable Number of first element
!       26-30        (I) Variable Initialization Flag (MODE)
!       31-45        (R) if MODE = 1;  value of all elements.
!       46-60        (R) SET by CADAC;  Points to the location in
!                        the storage array to the data.
!       61-62        (I) Stage number for multi run cases.

!--Argument List Definitions--------------------------------------------

!  IR2    - (I) Input. The second integer input on the card = submodule
!               number.
!  VR(I)  - (R) Input. The two real values input on the card.
!  MODE   - (I) Input. The number of variables in the array as a + or -
!               value as a flag for variable initialization.
!  NSTAGE - (I) Input.  The number of the stage currently being
!               processed.
!  ISWTH  - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------

!  ICARDTYPE - (I) The card type that is currently being processed.

!-------------------------------------------------------------------------



INTEGER, INTENT(IN OUT)                  :: ir2
INTEGER, INTENT(IN)                      :: mode
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(IN)                      :: nstage
INTEGER, INTENT(OUT)                     :: iswth
COMMON /c7wkd/  iwc7s0, wc7s0(10,20), iwc7sn(20), wc7sn(20,5,20)

COMMON  c(3510)





icardtype = 7


!     Check for an invalid variable number (C location) to be
!     initialized.

IF( ir2 <= 0  .OR.  ir2 > 3510 ) THEN
  iswth = 7
  CALL oin1_emsg( icardtype )
  RETURN
END IF


IF( mode > 0 ) THEN
  
!         Initialize the elements to individual values.
  
  iset = INT( vr(2) )
  
  IF( nstage < 1 ) THEN
    
    DO i = 1, mode
      c( ir2 + ( i-1 ) ) = wc7s0( iset, i )
    END DO
    
  ELSE
    
    DO i = 1, mode
      c( ir2 + ( i-1 ) ) =  wc7sn( nstage, iset, i )
    END DO
  END IF
  
ELSE
  
!         Mode < 0:  Initialize elements to same value.
  
  nelements = ABS( mode )
  
  DO i = 1, nelements
    c( ir2 + ( i-1 ) ) = vr(1)
  END DO
  
END IF


RETURN
END SUBROUTINE c7_process

SUBROUTINE c8_process

!-------------------------------------------------------------------------

!   Card type 8 : Read and set up weather data.  Display the data to
!   the output file.


!    Card Format:
!      Column       Description
!        1-2         (I) "08" = Card type number

!    Card Format of following weather deck (Max of 50 cards):
!        Free field format on each record with the information in the
!        following order (values must be entered for all parameters):
!             Altitude (Ft-ASL), Wind direction (Deg),
!             Wind Velocity (Ft/Sec), Density (Slugs/Ft**3),
!             Temperature (Deg F), Pressure (Lb/Ft**2)

!   Metric units are respectively: ( M-ASL), (Deg), (M/Sec), (Kg/M**3),
!             (Deg C), (Pascals)


!--Local Variable Definitions-------------------------------------------

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /winds/  walt(50), wdir(50), wvel(50), rhx(50),  &
    ctmp(50), wpres(50), kountw, rhw

COMMON /wsetwt/ wx(6,50)


EQUIVALENCE (c(0053), optmet    )


!---  Write the weather headers:

WRITE(id_tabout,440)
440 FORMAT( / '****  WEATHER DATA  ****', //  &
    '   ALTITUDE ', '  WIND DIR  ', '  WIND VEL  ',  &
    '  DENSITY   ',  '  TEMPRTR   ', '  PRESSURE  ' )


IF( optmet < 1.0 ) THEN
  
!         English units - write appropriate headers.
  
  WRITE(id_tabout,460)
  460     FORMAT( '  FEET,MSL  ', '  DEGREES   ', '  FT/SEC   ',  &
      '  SLG/FT**3 ',  '  DEG FAR   ', '  LB/FT**2  ' )
  
ELSE
  
!         Metric Units - Write appropriate headers.
  
  WRITE(id_tabout,500)
  500     FORMAT(  '  METERS,MSL', '  DEGREES   ', '  METERS/SEC',  &
      '  KG/M**3   ',  '  DEG CENT  ', '  PASCALS   ' )
  
END IF


!     Load the working arrays from the data input arrays.

DO i = 1, kountw
  walt(i)  = wx(1,i)
  wdir(i)  = wx(2,i)
  wvel(i)  = wx(3,i)
  rhx(i)   = wx(4,i)
  ctmp(i)  = wx(5,i)
  wpres(i) = wx(6,i)
  
  rhw   = walt(i)
  
  WRITE(id_tabout,540) walt(i),wdir(i),wvel(i),rhx(i),ctmp(i),wpres(i)
  540    FORMAT( 1X, 1P6E12.3 )
  
END DO

WRITE(id_tabout,*) '   '
WRITE(id_tabout,*) '****  END OF WEATHER DATA  ****'
WRITE(id_tabout,*) '   '


RETURN
END SUBROUTINE c8_process

SUBROUTINE c9_process( ir2 )

!-------------------------------------------------------------------------

!  Header cards.  This module allows up to 5 cards of text data to be
!  entered and displayed on the output.

!    Card Format:
!      Column       Description
!        1-2         (I) "09" = Card type number
!        25          (I) Number of header cards that follow ( N <= 5)

!    Header Card Format:
!      Column       Description
!      1-80         (C) Text to be saved and displayed.

!--Argument List Definitions--------------------------------------------

!  IR2   - (I) Input. The second integer input on the card = Number of
!          header cards following.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
COMMON /coller/ hol(5)
CHARACTER (LEN=80) :: hol

COMMON /wsetc/  al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al


numhol = ir2

DO ix = 1, numhol
  hol(ix) = holl(ix)
END DO


RETURN
END SUBROUTINE c9_process

SUBROUTINE c10_process( ir2, iswth )

!-------------------------------------------------------------------------

!  This module process the data entered on the record(s) following a type 10
!  card.  This record contains the conditions for staging.  A maximum of
!  two staging tests/variables/records may be entered.

!-------------------------------------------------------------------------

!  IR2 - (I) Input. The number of staging tests/variables entered on the
!            type 10 card.
!  ISWTH - (I) Output.  Error flag set as necessary by this module.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(OUT)                     :: iswth
COMMON  c(3510)


COMMON /stage/   loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest

COMMON /stage1/  istage, numstage

COMMON /stagec/  name1(2), name2(2)
CHARACTER (LEN=6) :: name2 chara ter*6 name1

COMMON /wsetsc/  mcri(20,2,4), wval(20,2)

COMMON /wsetscc/ mcric(20,2,2)
CHARACTER (LEN=6) :: mcric



ntest  = ir2
IF( ntest /= 1  .AND.  ntest /= 2 ) ntest = 1

!     Increment stage number

numstage = numstage + 1

DO i = 1, ntest
  
!            Transfer staging criteria data to the actual working arrays.
  
  name1(i) = mcric( numstage, i, 1 )   ! Stage Variable Name
  loc(i)   = mcri( numstage, i, 1 )    ! C Element location
  incrs(i) = mcri( numstage, i, 2 )    ! Flag
  name2(i) = mcric( numstage, i, 2 )   !
  val(i)   = wval( numstage, i )       ! Real data value
  units(i) = mcri( numstage, i, 3 )    ! ?
  kode(i)  = mcri( numstage, i, 4 )    ! Kode flag
  
!            Check for an invalid C element location
  
  IF( loc(i) <= 0 .OR. loc(i) > 3510 ) iswth = 10
  
!            Check for an invalid staging flag
  
  IF( IABS( incrs(i) ) > 1 ) iswth = 10
  
!            Check for an invalid KODE flag:
  
  IF( kode(i) > 1 ) iswth = 10
  
  IF( kode(i) == 1 ) THEN
    
!                VAL contains a C element location.
!                Check for invalid C element location
    
    IF( val(i) < 1.0  .OR.  val(i) > 3510.0 ) iswth = 10
  END IF
  
  
  l = loc(i)    ! C element location of the staging variable
  
  IF( kode(i) < 0 ) THEN
    
!                Add the value VAL to the current contents of the C
!                element location specified in LOC.  During simulation,
!                this sum, TEST, is compared to the contents of the
!                element specified in LOC to determine staging.
    
    test(i) = c(l) + val(i)
    
  ELSE IF( kode(i) > 0 ) THEN
    
!                The contents of the C element location is to be used as
!                the staging criteria.
    
    loct(i) = val(i)
    
  ELSE
    
!                The value, VAL, is to be used as the stage criteria
    
    test(i) = val(i)
    
  END IF
  
!            If time is the staging variable, decrease the test value
!            slightly.
  
  IF( l == 2000 ) test(i) = test(i) - 0.000001
  
END DO


RETURN
END SUBROUTINE c10_process

SUBROUTINE c11_process( ir2, alpha, vr, iswth, ir3 )

!-------------------------------------------------------------------------
!  This module performs the processing for data input with card type
!  11.

!    Card Format:
!      Column       Description
!       1-2         (I) "11" = Card type number
!       3-8         (C) Name of the controlled variable (Not used)
!       9           (C) Combination Code.  Must be either: ' ', '=',
!                       '+', '*', '-'
!       10-14       (C) Name of function
!       15-20       (C) Not used
!       21-25       (I) C Element number of the controlled variable. IR2
!       26-30       (I) Activated under task SEU 91-02 - Definition
!                       depends on the function's definition.  Not
!                       used for most functions. IR3
!       31-45       (R) 1st parameter.  If zero or blank, the current
!                       value will be used.
!       46-60       (R) 2nd parameter.


!--Argument List Definitions--------------------------------------------

!  IR2      - (I) Input. The second integer input on the card =
!              controlled variable number.
!  ALPHA(3) - (C) Input. All of the character data input on the card
!             type 11
!  VR(2)    - (R) Input. Both real variables input on the card.
!  ISWTH    - (I) Output. Input Error flag.
!  IR3      - (I) Input. The third integer input on the card.  Use
!             depends on the function definition.

!--Local Variable Definitions-------------------------------------------

!  CCODE(5)  - (C1) The combination codes in character format.
!  CHRCODE   - (C1) The character code entered by the user.
!  CHRFUNCT  - (C5) The function type entered by the user in character
!              format.
!  FUNCT(14) - (C5) The keywords for the available function types.
!  ICARDTYPE - (I) The card type that is currently being processed.
!  ICODE     - (I) The combination code deciphered and in integer
!              format.
!  NUMFUNCT  - (I) The maximum number of available functions.  Also the
!              array size of FUNCT.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: ir2
CHARACTER (LEN=1), INTENT(IN)            :: alpha(3)
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(OUT)                     :: iswth
INTEGER, INTENT(IN)                      :: ir3
COMMON  c(3510)

COMMON /ccom/ icf(25), icc(25), icl(25), ca(25), cl(25), ct0(25), nc, icl2(25)


EQUIVALENCE (c(2000), time )



CHARACTER (LEN=1) :: *6, chrcode*1, chrfunct*5, funct(15)*5, ccode(5)*1


DATA ccode/ ' ',  '=',  '+',  '-',  '*'  /,  &
    funct/ 'STEP ', 'RAMP ', 'PARAB', 'SIN  ', 'COS  ',  &
'TRI  ', 'GAUSS', 'UNIF ', 'DECAY', 'SQR  ',  &
    'SUM  ', 'PROD ', 'DIFF ', 'RAYLE', 'EQUAL'  /, numfunct/ 15 /



icardtype = 11


!---  Parse the combination code and the type function from the input
!     character string.

chrcode = alpha(2)(1:1)
chrfunct = alpha(2)(2:6)


IF( chrfunct == 'END  ' ) THEN

!         END function selected - Deactivate all control functions

nc = 0

RETURN
END IF


!---  Check for an invalid C element location entered in IR2

IF( ir2 <= 0  .AND.  ir2 > 3510 ) THEN
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Determine the combination code.

icode = 0
DO  i = 1, 5
  IF( chrcode == ccode(i) ) icode = i
END DO

IF( icode == 0 ) THEN
  
!         Invalid combination code entered.
  
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Determine the function type.

ifunct = 0
DO i = 1, numfunct
  IF( chrfunct == funct(i) ) ifunct = i
END DO

IF( ifunct == 0 ) THEN
  
!         Invalid function type - Exit the module with an error message.
  
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


IF( ifunct > 10  .AND.  ifunct < 14 ) THEN
  
!         Sum, Diff or Prod functions were selected.  The last two Real
!         variables input must contain C element locations.  Insure that
!         valid C locations are entered in these variables.
  
  DO i = 1, 2
    IF( vr(i) <= 0.0  .OR.  vr(i) > 3510.0 ) THEN
      iswth = 11
      CALL oin1_emsg( icardtype )
      RETURN
    END IF
  END DO
  
ELSE IF( ifunct == 15 ) THEN
  
!         The equal function was selected.  The first Real variable
!         input must contain a C element location.  Insure that
!         a valid C locations is entered.
  
  IF( vr(1) <= 0.0  .OR.  vr(1) > 3510.0 ) THEN
    iswth = 11
    CALL oin1_emsg( icardtype )
    RETURN
  END IF
END IF

!---

IF( nc == 25 ) THEN
  
!         Maximum number of functions have been defined.  Don't allow
!         any more definitions.  Give error message and return.
  
  iswth = 11
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Valid data has been input.  Define the functions.

nc      = nc + 1      ! Increment the number of defined functions.

!     Store the input data in their respective arrays:

icf(nc) = ifunct      ! Function Type
icc(nc) = icode       ! Combination Code
icl(nc) = ir2         ! Controlled variable
icl2(nc) = ir3        ! Integer parameter

!     Store the first variable or, if 0.0 was entered, save the current
!     value of the controlling variable.

ca(nc)  = vr(1)       ! 1st parameter
IF( ca(nc) == 0.0  )  ca(nc) = c( ir2 )

cl(nc)  = vr(2)       ! 2nd parameter
ct0(nc) = time        ! Current time at function definition


IF( ifunct == 7 ) THEN
  
!         GAUSS function selected - initialize CT0 to 0.0 and apply the
!         negative to the beta at this point.  A = EXP( -Beta * DT)
!         where Beta is the 2nd parameter input.
  
  ct0(nc) = 0.0
  cl(nc)  =  - ABS( cl(nc) )
  
ELSE IF( ifunct == 14 ) THEN
  
!         RAYLE function selected - The integer parameter is the number
!         of integration intervals the value of the function is to be
!         maintained (ie like a step width).  Insure that this variable
!         is greater than zero. If the variable is zero, force a
!         default value of 5.
  
  IF( icl2(nc) <= 0.0 ) icl2( nc ) = 5
  
!         Also set the CT0 definition for this function.  CT0 is the
!         time where the next obstical is to be encountered = Current
!         time at function definition + delta time until the next obstical
!         is encountered.
  
  emean = ca(nc)            ! 1st parameter
  deltobs = expon( emean )  ! Time between obsticals in seconds.
  
!         Add this to the current time already stored in Ct0.
  
  ct0( nc ) = ct0( nc ) + deltobs
  
ELSE IF( ifunct == 15 ) THEN
  
!         EQUAL function - Go ahead and set the initial value of
!         this function.  This is to prevent the function from having an
!         incorrect value during the time between the function's initiation
!         and the first function evaluation.
  
  k1 = vr(1)               ! Intergerize the element number
  c( ir2 ) = c( k1 )       ! Get the current value.
  
  
END IF



RETURN
END SUBROUTINE c11_process

SUBROUTINE c90_process

!-------------------------------------------------------------------------

!   Type 90 card stores state on file -tape90-
!   Type 91 card restores state from file -tape90-
!   Routine loaded inline.

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /oindat/  j16, icd, i16

COMMON /stage1/  istage, numstage

DIMENSION ic(3510)
EQUIVALENCE (c(0001), ic(0001) )
!---
!------------------------PC Code-------------------------------------
!---
OPEN( id_csave, FILE='CSAVE.ASC', STATUS='UNKNOWN' )
WRITE(id_csave,*) c, ic

CLOSE( id_csave )

!--------------------------------------------------------------------

!     Write a message to the output file.

WRITE(id_tabout,*) ' WRITE ON CSAVE.ASC '  ! TAPE90 '

!     End routine loaded inline.
!     Store the stage number where the save occurred, save the card number
!     and set the save flag

ibegin = numstage
icard  = icd
isave  = 1


RETURN
END SUBROUTINE c90_process

SUBROUTINE comprt

!-------------------------------------------------------------------------


!-------------------------------------------------------------------------

COMMON      c(3510)

RETURN
END SUBROUTINE comprt

SUBROUTINE cntrol( j1, j2 )

!-------------------------------------------------------------------------

!  This module  contains the type 11 card implementation.
!  Type 11 cards are used by the analyst to define forcing functions,
!  superimpose noise on selected variables, and combine selected
!  variables.
!  This module is called after each integration and prior to the calls
!  to the modules to update the value of the variable (in accordance
!  with the defined function) for the current time.

!--Argument List Definitions--------------------------------------------

!  J1 - (I) 1 at call prior to modules in auxsub; 0 in call after
!       modules in auxsub.
!  J2 - (I) submodule number.

!--Local Variable Definitions-------------------------------------------

!  SAV_VALUE(25) - (R) An array for saving the computed GAUSS, UNIF or
!                  RAYLE values at the predictor stage (ICOOR = 0) or
!                  initialization (ICOOR = -1) and
!                  then re-loading these same values at the corrector
!                  stage (ICOOR=1).  HOWEVER, a discrepancy exists
!                  due to the type 11, module-associated C locations
!                  are computed AFTER the module, and the value is actually
!                  for the NEXT module call.  So for these variables,
!                  this needs to switch

!-------------------------------------------------------------------------



INTEGER, INTENT(IN)                      :: j1
INTEGER, INTENT(IN OUT)                  :: j2
COMMON        c(3510)

COMMON /ccom/ icf(25), icc(25), icl(25), ca(25), cl(25), ct0(25), nc, icl2(25)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


DIMENSION der(101)

EQUIVALENCE (c(2000), time   )
EQUIVALENCE (c(2664), der(1) )
EQUIVALENCE (c(2866), icoor )

!     TIME   = The current time in the integration process
!     DER(1) = The Integration step size
!     ICOOR  = FLAG: 0 = Prediction cycle of integrator; 1 = Correction
!              cycle;  -1 = Initialization cycle.

INTEGER :: ll(37), ul(37)
DIMENSION sav_value( 25 )


!---  The two following data cards may require an update if:

!          1.  A module different than those listed in "AUXSUB" is added.
!          2.  The storage bounds of a module are altered,
!              i.e. storage locations for module s2 are 600-749
!              instead of the old locations  600-699.

!--- The storage locations below are sequenced to match the module
!    number, NOSUB, as follows:
!    Nosub     Name Locations
!    1               1-99 = Unassigned module number = Executive ?
!    2    A1   1200-1299
!    3    A2   1300-1399
!    4    A3   1400-1499
!    5    A4   1500-1599
!    6    A5   Dummy module - no commons assigned.
!    7    C1   800-899
!    8    C2   900-999
!    9    C3   1000-1099
!    10   C4   1100-1199
!    11   C5   Dummy module - no commons assigned.
!    12   C6   Dummy module - no commons assigned.
!    13   C7   Dummy module - no commons assigned.
!    14   C8   Dummy module - no commons assigned.
!    15   C9   Dummy module - no commons assigned.
!    16   C10  Dummy module - no commons assigned.
!    17   D1   1600-1699
!    18   D2   1700-1799
!    19   D3   1800-1899  ? Growth module
!    20   D4   1900-1999  ? Debug module
!    21   D5   Dummy module - no commons assigned.
!    22   G1   100-199
!    23   G2   200-299
!    24   G3   300-399
!    25   G4   Dummy module - no commons assigned.
!    26   G5   Dummy module - no commons assigned.
!    27
!    28   S1   400-499
!    29   S2   500-599
!    30   S3   600-699
!    31   S4   700-799
!    32   S    Dummy module - no commons assigned.
!    34   S6   Dummy module - no commons assigned.
!    35   S8   Dummy module - no commons assigned.
!    36   S9   Dummy module - no commons assigned.
!    37        Dummy module - no commons assigned.


DATA ll/    1, 1200, 1300, 1400, 1500,    0,  800,  900,  &
    1000, 1100,    0,    0,    0,    0,    0,    0,  &
    1600, 1700,    0,    0,    0,  100,  200,  300,  &
    0,    0,    0,  400,  500,  600,  700,    0, 0,    0,    0,    0,    0/

!     Ending C element location for initialization:

DATA ul/   99, 1299, 1399, 1499, 1599,    0,  899,  999,  &
    1099, 1199,    0,    0,    0,    0,    0,    0,  &
    1699, 1799,    0,    0,    0,  199,  299,  399,  &
    0,    0,    0,  499,  599,  699,  799,    0, 0,    0,    0,    0,    0 /



!---  If no forcing functions are defined, then exit the module.

IF( nc <= 0 ) RETURN


!     For each defined forcing function:

DO i = 1, nc
  
!        IV = The variable (C location) being controlled by a function
  
  iv = icl(i)
  
  
!         Original coding:  This block was left for reference but
!         recoded in a more structured/understandable format.
!         IF( J1 .EQ. 0   .OR.   IV .LE. 1799 ) THEN
!            Cntrol is being called after a module has been executed.
!            Check if the type 11 controlled variable is a part of that
!            module.  If it is outside the module's common area, then
!            skip the function update.
!             IF( IV .LT. LL(J2)  .OR.  IV .GT. UL(J2) ) GOTO 1000
!         ENDIF
  
  IF( j1 == 0 ) THEN
    
!            Called after a module is executed :
    
!            Evaluate the function if the common location is assigned to
!            the module just executed.  If the common location is
!            outside this range, then skip the function evaluation
    
    IF( iv < ll(j2)  .OR.  iv > ul(j2) ) GO TO 1000
    
  ELSE
    
!            J1 = 1 : Called prior to evaluation of any modules:
    
!            If the common location is outside the ranges
!            1799-3510  AND  1-99  then skip the function evaluation.
    
    IF( iv < ll(j2)  .OR.  iv > ul(j2) ) THEN
      
!                Common location is outside the range 1-99
      
      IF( iv < 1799 .OR.  iv > 3510 ) GO TO 1000
    END IF
    
  END IF
  
  
!        Load the function information into local variables for
!        computations:
  
  ic = icc(i)          ! Combinaton code
  tc = time - ct0(i)   ! Delta time since definition
  a = ca(i)            ! 1st parameter
  b = cl(i)            ! 2nd parameter
  ip2 = icl2( i )      ! Second optional integer parameter.
  kf = icf(i)          ! Forcing function
  
  
!        Branch to the code for the selected function :
  
  SELECT CASE ( kf )
    CASE (    1)
      GO TO  110
    CASE (    2)
      GO TO  120
    CASE (    3)
      GO TO  130
    CASE (    4)
      GO TO  140
    CASE (    5)
      GO TO  150
    CASE (    6)
      GO TO  160
    CASE (    7)
      GO TO  170
    CASE (    8)
      GO TO  180
    CASE (    9)
      GO TO 190
    CASE (   10)
      GO TO  200
    CASE (   11)
      GO TO  210
    CASE (   12)
      GO TO  210
    CASE (   13)
      GO TO  210
    CASE (   14)
      GO TO  220
    CASE (   15)
      GO TO  230
  END SELECT
  
  
  WRITE(id_tabout,*) '  GOTOER IN CONTROL, KF = ', kf
  
  
  110    CONTINUE
  
!---     Step function
  
  xvalue = a
  GO TO 900
  
  
  120    CONTINUE
  
!---     Ramp function
  
  xvalue  = b * tc
  
!        Insure that  -A <= XVALUE <= A
  
  aa = ABS(a)
  xvalue = AMAX1( -aa, AMIN1( aa, xvalue ) )
  GO TO 900
  
  
  130    CONTINUE
  
!---     Parabola function
  
  xvalue = b * tc * tc
  
!        Insure that  -A <= XVALUE <= A
  
  aa = ABS(a)
  xvalue  = AMAX1( -aa, AMIN1(aa, xvalue ) )
  GO TO 900
  
  
  140    CONTINUE
  
!---     Sine function
  
  xvalue = a * SIN( 6.2831853 * tc / b )
  GO TO 900
  
  
  150    CONTINUE
  
!---     Cosine Function
  
  xvalue = a * COS( 6.2831853 * tc / b )
  GO TO 900
  
  
  160    CONTINUE
  
!---     Triangular wave function
  
  xvalue = tri( a, b, tc )
  GO TO 900
  
  
  170    CONTINUE
  
!--      Gaussian Noise
  
!         Code added under XR92 to insure that the same Xvalue is used
!         at both predictor and corrector cycles.
  
  IF( j1 /= 1 ) THEN
    
!            The C location is associated with a module - the computation
!            occurrs at ICOOR = N but is used within the modules at
!            ICOOR = N+1
    
    IF(  icoor > 0 .OR.  icoor == -1 ) THEN
      
!                 Modules are in Correction Cycle or Initialization,
!                 but the values generated NOW will be used for the
!                 Predictor Cycle.  Therefore save these values.
      
      CALL cnt_gauss( a, b, time, der(1), ct0(i), xvalue )
      sav_value(i) = xvalue
      
    ELSE
      
!                 Modules are in Prediction Cycle but the values loaded
!                 NOW will be used in the Corrector Cycle.
      
      xvalue = sav_value( i )
    END IF
    
  ELSE
    
!            The C locations NOT associated with a module are being
!            evaluated.  These are evaluated PRIOR to executing any
!            modules therefore ICOOR will have the same value during
!            evaulation and when the module is using the value.
    
    IF(  icoor < 1 ) THEN
      
!                 Modules are in Prediction Cycle or initialization.
!                 Values generated NOW will be used for the Predictor
!                 Cycle module execution.  Therefore save these values.
      
      CALL cnt_gauss( a, b, time, der(1), ct0(i), xvalue )
      sav_value(i) = xvalue
      
    ELSE
      
!                 Modules are in CORRECTION Cycle.  The values loaded
!                 NOW will be used in the Corrector Cycle.
      
      xvalue = sav_value( i )
    END IF
    
  END IF
  
  GO TO 900
  
  
  180    CONTINUE
  
!---     Uniform function
  
  IF( j1 /= 1 ) THEN
    
!            The C location is associated with a module - the computation
!            occurrs at ICOOR = N but is used within the modules at
!            ICOOR = N+1
    
    IF(  icoor > 0 .OR.  icoor == -1 ) THEN
      
!                 Modules are in Correction Cycle or Initialization,
!                 but the values generated NOW will be used for the
!                 Predictor Cycle.  Therefore save these values.
      
      xvalue        = unif( a, b )
      sav_value( i ) = xvalue
      
    ELSE
      
!                 Modules are in Prediction Cycle but the values loaded
!                 NOW will be used in the Corrector Cycle.
      
      xvalue = sav_value( i )
    END IF
    
  ELSE
    
!            The C locations NOT associated with a module are being
!            evaluated.  These are evaluated PRIOR to executing any
!            modules therefore ICOOR will have the same value during
!            evaulation and when the module is using the value.
    
    IF(  icoor < 1 ) THEN
      
!                 Modules are in Prediction Cycle or initialization.
!                 Values generated NOW will be used for the Predictor
!                 Cycle module execution.  Therefore save these values.
      
      xvalue        = unif( a, b )
      sav_value(i) = xvalue
      
    ELSE
      
!                 Modules are in CORRECTION Cycle.  The values loaded
!                 NOW will be used in the Corrector Cycle.
      
      xvalue = sav_value( i )
    END IF
    
  END IF
  
  GO TO 900
  
  
  190    CONTINUE
  
!---     Decay function
  
  xvalue = decay( a, b, tc )
  GO TO 900
  
  
  200    CONTINUE
  
!---     Square wave function
  
  xvalue = sqr( a, b, tc )
  GO TO 900
  
  
  210    CONTINUE
  
!---     Summing, product, and difference functions.  A and B contain
!        the C element locations of the variables to be summed, multiplied
!        or differenced.
  
  k1 = a + 0.5
  k2 = b + 0.5
  
  IF( kf == 11 ) THEN
    
    xvalue = c(k1) + c(k2)       ! Sum
    
  ELSE IF( kf == 12 ) THEN
    
    xvalue = c(k1) * c(k2)       ! Product
    
  ELSE IF( kf == 13 ) THEN
    
    xvalue = c(k1) - c(k2)       ! Differenced
    
  END IF
  
  GO TO 900
  
  
  
  220    CONTINUE
  
!---     Special Rayleigh function added for Dr. Zipfel under task
!        SEU 91-2
  
  IF( j1 /= 1 ) THEN
    
!            The C location is associated with a module - the computation
!            occurrs at ICOOR = N but is used within the modules at
!            ICOOR = N+1
    
    IF(  icoor > 0 .OR.  icoor == -1 ) THEN
      
!                 Modules are in Correction Cycle or Initialization,
!                 but the values generated NOW will be used for the
!                 Predictor Cycle.  Therefore save these values.
      
      CALL cnt_rayle( a, b, time, ct0(i), ip2, der(1), i, xvalue  )
      sav_value( i ) = xvalue
      
    ELSE
      
!                 Modules are in Prediction Cycle but the values loaded
!                 NOW will be used in the Corrector Cycle.
      
      xvalue = sav_value( i )
    END IF
    
  ELSE
    
!            The C locations NOT associated with a module are being
!            evaluated.  These are evaluated PRIOR to executing any
!            modules therefore ICOOR will have the same value during
!            evaulation and when the module is using the value.
    
    IF(  icoor < 1 ) THEN
      
!                 Modules are in Prediction Cycle or initialization.
!                 Values generated NOW will be used for the Predictor
!                 Cycle module execution.  Therefore save these values.
      
      CALL cnt_rayle( a, b, time, ct0(i), ip2, der(1), i, xvalue  )
      sav_value(i) = xvalue
      
    ELSE
      
!                 Modules are in CORRECTION Cycle.  The values loaded
!                 NOW will be used in the Corrector Cycle.
      
      xvalue = sav_value( i )
    END IF
    
  END IF
  
  GO TO 900
  
  
  230    CONTINUE
  
!------  Function number 15 - equality function.  The controlled
!        variable is assigned the current value of a user selected C
!        element.
  
  k1 = a              ! Intergerize the element number
  xvalue = c( k1 )    ! Get the current value.
  
  GO TO 900
  
  
  
  900    CONTINUE
  
!---     Combine with the controlled variable depending on the
!        combination code.
  
  IF( ic <= 2 ) THEN
    
!            ' ' or '=' combination code: Replace C with XVALUE
    
    c(iv) = xvalue
    
  ELSE IF( ic == 3 ) THEN
    
!            '+' combination code - Add XVALUE to C
    
    c(iv) = c(iv) + xvalue
    
  ELSE IF( ic == 4 ) THEN
    
!            '-' combination code - Subtract XVALUE from C
    
    c(iv) = c(iv) - xvalue
    
  ELSE IF( ic == 5 ) THEN
    
!            '*' combination code - Multiply XVALUE and C
    
    c(iv) = c(iv) * xvalue
  END IF
  
  
  1000    CONTINUE   ! Go check the next function.
  
END DO


RETURN
END SUBROUTINE cntrol

SUBROUTINE cnt_gauss( asig, btcor, time, der, ct0i, xvalue )

!-------------------------------------------------------------------------

!  This module performs the calculation for a time-correlated Gaussian
!  stochastic variable for TYPE 11 CARD function.  This module is called
!  by the CNTROL module

!--Argument List Definitions--------------------------------------------

!  ASIG  - (R) Input.  The sigma for the gaussian stochastic variable
!          forming the basis of the time correlated Gauss for type 11.
!  BTCOR - (R) Input.  The Beta time correlation coefficient.  This is
!          normally a negative value and therefore is negated in the
!          C11_PROCESS module.
!  TIME  - (R) Input.  The current time.
!  DER   - (R) Input.  The time step size.
!  CT0I  - (R) In/Out.  The previous value generated for the function.
!  XVALUE - (R) Out.  The current value generated for the function.

!-------------------------------------------------------------------------


xvalue = gauss( asig, 0.0 )

!     Apply time correlation

IF( time == 0.0 ) THEN
  ct0i = xvalue
  
ELSE
  
  IF( btcor /= 0.0 ) THEN
    
!             NOTE:  BTCOR  has already been negated during the
!             C11_PROCESS module.
    
    d = EXP( btcor * der )
    dsqrd  = d * d
    
    xvalue = xvalue * SQRT( 1.0 - dsqrd ) + ct0i * d
    
    ct0i = xvalue
  END IF
END IF


RETURN
END SUBROUTINE cnt_gauss

SUBROUTINE cnt_rayle( alambda, rmode, time, ct0i, ip2, der, nfunct, xvalue)

!-------------------------------------------------------------------------

!  Special Rayleigh function added for Dr. Zipfel under task
!  SEU 91-02.

!--Argument List Definitions--------------------------------------------

!  ALAMBDA   - (R) Input. Exponential parameter (lambda = A )
!  RMODE     - (R) Input. Rayleigh mode parameter ( B )
!  TIME      - (R) Input. The current trajectory time.
!  CT0I      - (R) Input. The time at initiation of the function?
!  IP2       - (I) Input. The number of integration cycles to hold
!                  the obsticle.
!  DER       - (R) Input. The current time step size.
!  NFUNCT    - (I) Input. The current function number being evaluated.
!                  (Max value = 25 )
!  XVALUE    - (R) Output. The obstical height returned by this function.

!--Local Variable Definitions-------------------------------------------

!  TENDOBS(25)   - (R) Time at the end of the obstical width.
!  SETHEIGHT(25) - (L) FLAG- an obstical is reached;  the obstical height
!                  AND time width need to be set.

!-------------------------------------------------------------------------


REAL, INTENT(IN)                         :: alambda
REAL, INTENT(IN)                         :: rmode
REAL, INTENT(IN)                         :: time
REAL, INTENT(IN OUT)                     :: ct0i
INTEGER, INTENT(IN)                      :: ip2
REAL, INTENT(IN)                         :: der
INTEGER, INTENT(IN OUT)                  :: nfunct
REAL, INTENT(OUT)                        :: xvalue
DIMENSION tendobs( 25 ), obsheight( 25 )
LOGICAL :: setheight( 25 )

DATA ( tendobs(i), i=1,25) / 25 * 0.0 /,  &
    ( obsheight(ii), ii=1,25)/ 25 * 0.0 /, ( setheight(j), j=1,25) / 25 * .true. /


IF( time >= ct0i ) THEN
  
!         The obstical has been reached.  Set the obstical height and
!         hold the value for the given number of integration intervals.
  
  IF( setheight( nfunct )  ) THEN
    
!             First time interval - Set the height value
    
    obsheight( nfunct ) = rayleigh( rmode )  ! Height of the obstical
    
!             Set the obstical time width.  Add 1 percent of the step
!             size to insure that the height is for the IP2 number of
!             steps and not IP2+1 due to roundoff and the way the
!             computer stores the numbers. ( ie T = 7.9999998 and
!             tendobs = 7.9999999 )
    
    tendobs( nfunct ) = time + ( ip2 * der ) - ( 0.1 * der )
    
!             Reset the flag:
    
    setheight( nfunct )  = .false.
    
  ELSE IF( time >= tendobs( nfunct )  ) THEN
    
!             End of the obstical has been reached.
!             End of step width reached.  Reset variables for next
!             obstical.
    
    obsheight( nfunct )  = 0.0   ! Set obstical height to 0.0
    
!             Reset the CT0 to point to the next time an obstical
!             occurs. TOBSTICAL = delta time until the next obstical;
!             T = current time.
    
    tobstical = expon( alambda )
    ct0i = time + tobstical
    
!             Set the flag so that the obstical height will be
!             defined when the next obstical is reached.
    
    setheight( nfunct )  = .true.
  END IF
  
  xvalue = obsheight( nfunct )
  
ELSE
  
!         The obstical has NOT yet been reached.  Set the obstical
!         height to 0.0 and maintain this until the obstical is reached.
  
  xvalue = 0.0
  
END IF


RETURN
END SUBROUTINE cnt_rayle

SUBROUTINE dattim

!-------------------------------------------------------------------------

!  This module inserts the current date and time into the job title at
!  character locations TITLE(72:100)

!--Local Variable Definitions-------------------------------------------

!  DDATE - (C9) The current system date as returned from the DATE
!          function.
!  DTIME - (C8) The current system time as returned from the TIME
!          function.

!-------------------------------------------------------------------------

COMMON /hcom/ title
CHARACTER (LEN=100) :: title
CHARACTER (LEN=100) :: tmptitle


DIMENSION months (12)
CHARACTER (LEN=9) :: DTIME
CHARACTER (LEN=11) :: !   ddate chara ter*4  cyr  &
    chara ter*3 months
INTEGER*2 iyr, imon, iday
CHARACTER (LEN=1) :: 8)  :: dt
CHARACTER (LEN=1) :: 10) :: tm
CHARACTER (LEN=1) :: 5)  :: zone
DATA months / 'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',  &
    'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC' /

!---  Get the current system date and time.
!---      CALL GETDAT( IYR, IMON, IDAY )
CALL date_and_time( date=dt, zone=zone )

WRITE(cyr,'(I4.4)') iyr
WRITE(ddate,100) iday, months(imon), cyr
100 FORMAT( i2.2, '-', a, '-', a )


!---   Dr. Zipfel requested that the time not be included in title (12/1994)
!      CALL GETTIM(IHR, IMIN, ISEC, IHUND )
!      WRITE(DTIME,200) IHR, IMIN, ISEC
!  200 FORMAT( I2.2, ':', I2.2, ':', I2.2 )


!---   The following statements are used in the SVS version of CADAC.
!      DDATE = SSPDAT(1)
!      DTIME = SSPTIM()


!---  Insert the data and time into the job title at the end.
!     TITLE(1:100) = TITLE(1:70) // ' ' // DDATE // ' ' // DTIME
IF( lenstr(title) <= 70 ) THEN
  tmptitle = title
  title = tmptitle(1:lenstr(tmptitle)) // '  ' // ddate
ELSE
  title(1:100) = title(1:70) // ' ' // ddate
END IF


RETURN
END SUBROUTINE dattim

FUNCTION decay( a, b, t )

!-------------------------------------------------------------------------


!--Argument Definitions-------------------------------------------------

!  A     - (R) Input.
!  B     - (R) Input.
!  T     - (R) Input.
!  DECAY - (R) Output.

!-------------------------------------------------------------------------

decay = a * EXP( -ABS( b * t ) )

RETURN
END FUNCTION decay



SUBROUTINE ld_deriv( numsv )

!-------------------------------------------------------------------------

!  This module loads the function initial data into the variable ( V ) and
!  variable derivative ( DER ) arrays.  The data is loaded from the C
!  array, where the initial values are loaded by the input deck and
!  modules.

!--Argument List Definition---------------------------------------------

!  NUMSV - (I) Input.  The number of state variables.  This was made a
!          passed variable due because different code locations used a
!          different variable in this position.

!-------------------------------------------------------------------------



INTEGER, INTENT(IN)                      :: numsv
COMMON          c(3510)

DIMENSION  der(101), ipl(100), v(101), iplv(100)

EQUIVALENCE (c(2000), time    )
EQUIVALENCE (c(2562), ipl(1)  )
EQUIVALENCE (c(2664), der(1)  )
EQUIVALENCE (c(2765), v(1)    )
EQUIVALENCE (c(2867), iplv(1) )


DO i = 2, numsv
  
!        Get the pointer into the C array for the state variable
!        derivative.
  
  noderiv  = ipl( i - 1 )
  
!        Get the pointer into the C array for the stage variable.
  
  IF( iplv( i-1 ) < 1 ) THEN
    nostate = noderiv + 3
  ELSE
    nostate = iplv( i-1 )
  END IF
  
!        Load the variable array with the initial value.
  
  v( i ) = c( nostate )
  
!        Load the derivative array with the derivative initial value.
  
  der( i ) = c( noderiv )
END DO

!     The first integration variable is always time.  Initialize this
!     variable.

v(1) = time


RETURN
END SUBROUTINE ld_deriv

SUBROUTINE ld_carray( numsv )

!-------------------------------------------------------------------------

!  This module loads the C Array from the variable ( V ) and
!  variable derivative ( DER ) arrays.  The data is loaded from the
!  arrays used in the integration technique.

!--Argument List Definition---------------------------------------------

!  NUMSV - (I) Input.  The number of state variables.  This was made a
!          passed variable due because different code locations used a
!          different variable in this position.

!-------------------------------------------------------------------------



INTEGER, INTENT(IN)                      :: numsv
COMMON          c(3510)

DIMENSION   der(101), ipl(100), v(101), iplv(100)

EQUIVALENCE (c(2000), time    )
EQUIVALENCE (c(2562), ipl(1)  )
EQUIVALENCE (c(2664), der(1)  )
EQUIVALENCE (c(2765), v(1)    )
EQUIVALENCE (c(2867), iplv(1) )


DO i = 2, numsv
  
!        Get the pointer into the C array for the state variable
!        derivative.
  
  noderiv  = ipl( i - 1 )
  
!        Get the pointer into the C array for the stage variable.
  
  IF( iplv( i-1 ) < 1 ) THEN
    nostate = noderiv + 3
  ELSE
    nostate = iplv( i-1 )
  END IF
  
!        Load the stage variable values generated by the integration
!        modules into the C array.
  
  c( nostate ) = v( i )
END DO


!     Load Time from the first variable.  Time is always 1.

time = v(1)


RETURN
END SUBROUTINE ld_carray

!--------------------------------------------------------------------
!

FUNCTION expon( rmean )
!
!--------------------------------------------------------------------
!
!    This function generates a random variable that is exponentially
!    distributed random with a mean of RMEAN.
!
!--------------------------------------------------------------------
!
!     RMEAN -  the mean of the exponential distribution; input by the
!              user.
!
!     EXPDEV - function to generate a random variable with an
!              exponential distribution with a mean and variance
!              of (1,1) using a uniform random function with a mean
!              of (0,1).
!
!     EXPON  - a random variable having a exponential distribution
!              with a mean and variance of (RMEAN,RMEAN**2).
!
!--------------------------------------------------------------------
!
expon = expdev() * rmean
!
RETURN
END FUNCTION expon
!
!--------------------------------------------------------------------
!

FUNCTION expdev()
!
!--------------------------------------------------------------------
!
!     EXPDEV - function to generate a random variable with an
!              exponential distribution with a mean and variance
!              of (1,1) using a uniform random function with a mean
!              of (0,1).
!
!            ( returns an exponentially distributed, positive,
!              random deviate of unit mean using RANF() as the
!              source of uniform deviates )
!
!
!--------------------------------------------------------------------
!
expdev = - ALOG ( ranf() )
!
RETURN
END FUNCTION expdev

!-------------------------------------------------------------------------

FUNCTION gauss( sig, xmean )

!-------------------------------------------------------------------------

!    This function performs the gaussian distribution to a variable.

!-------------------------------------------------------------------------

!    Arguments:

!       SIG   -
!       XMEAN -

!    Local variables:

!       REAL:

!         TERM -
!         V1   -
!         V2   -
!         V1V2 -
!         X    -

!       LOGICALS:

!          DONE - indicates that
!          SW   -

!-------------------------------------------------------------------------


REAL, INTENT(IN)                         :: sig
REAL, INTENT(IN)                         :: xmean
COMMON /flag1/ initgauss
LOGICAL :: initgauss


LOGICAL :: done


!    The SW flag was changed to an INITGAUSS assignment and added in 1992
!    during the modifications to
!    allow individual trajectories from a multirun case to be duplicated
!    in a single run.  The GAUSS function provided a problem as the SW
!    was initialized in a data statement to false; When only used once in a
!    trajectory, the trajectories became "paired" with the Nth trajectory
!    using V1 deviate and the N+1th trajectory using V2. This made
!    duplication of the N+1th traj. impossible without running the Nth traj.
!    Therefor the switch is set to false at the beginning of each trajectory,
!    forcing the calculation of a new set of deviates for the given seed.
!    This should not pose a stat problem since an even number of GAUSS calls
!    within a single trajectory will always use a particular deviate for
!    calculating that variable, which produces the same situation.


IF( initgauss ) THEN
  x = v2*term
  
ELSE
  
!        Find a pair of random deviates
  
  done = .false.
  DO WHILE ( .NOT. done )
    v1 = 2. * ranf() - 1.0
    v2 = 2. * ranf() - 1.0
    v1v2 = v1 * v1 + v2 * v2
    IF( v1v2 < 1. ) done = .true.
  END DO
  
  term = SQRT( -2. * ALOG( v1v2 ) / v1v2 )
  
  x = v1 * term
END IF

!     Calculate the reqired random value.

gauss = x * sig + xmean

!     Change the switch value.

initgauss = .NOT. initgauss


RETURN
END FUNCTION gauss



SUBROUTINE ini1_vars

!-------------------------------------------------------------------------

!  This module initializes several C variables that contain earth
!  constants and conversion factors.  This initialization procedure is
!  executed at the begining of each group (?) of runs.

!-------------------------------------------------------------------------

COMMON        c(3510)

EQUIVALENCE (c(0051), rearth)
EQUIVALENCE (c(0052), crad  )
EQUIVALENCE (c(0054), agrav )
EQUIVALENCE (c(0055), cftm  )
EQUIVALENCE (c(0056), ckfps )
EQUIVALENCE (c(0057), amu   )
EQUIVALENCE (c(0058), weii3 )


!---  Conversion factor,  CRAD: multiply times radians to obtain degrees.

crad = 57.29577951

!---  Conversion factor,  CFTM: multiply times feet to obtain meters.

cftm   = .3048006

!---  Conversion factor, CKFPS: multiply times knots to obtain ft/sec.

ckfps  = 1.6878

!---  Radius of the Earth (ft)

rearth = 20902190.

!--- Gravitational parameter mu for the Earth (ft^3/sec^2)

amu    = 1.407645E+16

!--- Acceleration due to gravity (ft/sec^2)

agrav  = 32.174


!---  WEII3 = omega = angular rotation of the earth (rad/sec)
!     This variable is initialized to the rotating earth model
!     (OPNORO=0).  If a NON rotating earth is desired, the OPNORO flag
!     should be set to 1.0 with a type 3 card.

weii3 = 7.2921154E-05


RETURN
END SUBROUTINE ini1_vars

SUBROUTINE ini1_pmin

!-------------------------------------------------------------------------

!  This module initializes the PMIN array to values appropriate for
!  detecting the minimum values of the plot variables.

!  NOTE:  Pmin = array containing the Minimum value of the plot
!                variable.

!--Argument List Definitions-------------------------------------------

!--Local Variable Definition--------------------------------------------

!-------------------------------------------------------------------------

COMMON  c(3510)

DIMENSION   pmin(70)

EQUIVALENCE (c(2127), pmin(1)   )


!     Initialize the Minimum array to a very large number.

DO i = 2, 70
  pmin(i) = .99999E37
END DO

!     NOTE:  the first plot variable is always time.  This is forced by
!     the program and independant of the input.  However, set the first
!     variable to -1.0 since this array is used to form the divider record
!     and the divider record has a -1.0 as the first number.

pmin(1) = -1.0


RETURN
END SUBROUTINE ini1_pmin

SUBROUTINE oinpt1

!-------------------------------------------------------------------------

!   This module processes the input card data.  The input card data is
!   read by module LARGE.  This module moves the data into the working
!   arrays and processes the information.

!--Local Variable Definition--------------------------------------------

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/  jrun, mulrun, igroup

COMMON /stage1/  istage, numstage

EQUIVALENCE (c(2361), nomod   )
EQUIVALENCE (c(2461), nosub   )

DATA iswth / 0 /



100 CONTINUE


!     Initialize some variables.

CALL oin1_init


!     Load the cards and process them

CALL oin1_process( iswth )


!     Check the print intervals and determine is it needs to be
!     adjusted.

CALL oin1_prtchk


!     Check to see if some "modules" have been selected for execution.

IF( nomod <= 0 ) THEN
  iswth = 101
  WRITE(id_tabout,1920)
  1920     FORMAT( '0------ ERROR. AT LEAST ONE MODULE MUST BE CALLED.',  &
      '     RUN ABORTED. ------' )
END IF


!---  Check to see if some "MODULES" have been selected for execution.
IF(  nosub <= 0 ) THEN
  iswth = 101
  WRITE(id_tabout,1940)
  1940     FORMAT( '0------ ERROR. AT LEAST ONE SUBROUTINE MUST BE '  &
      'CALLED.     RUN ABORTED. ------')
END IF


!---  This is the original error check.  This was modified under T9108
!---  If an error occurs and the end of the primary trajectory
!---  has not been reached, then continue reading the cards.
!---  IF( ISWTH .NE. 0  .AND.  ISTAGE .NE. 6 ) GOTO 100
!---  Otherwise - no error and reached a 16/12 card, or the end of the
!---  primary trajectory data cards - Calculate the trajectory.

IF( iswth /= 0 ) THEN
  
!         An error occurred during the input.
  
  IF( igroup < 2 ) THEN
    
!---           The input error occurred while reading the primary
!---           trajectory.  Stop the program so that the user can fix
!---           the error.
    WRITE(id_tabout,*) ' ERROR ON INPUT - PROGRAM STOPPED. ERROR=', iswth
    WRITE(id_tabout,*) ' '
    WRITE(id_tabout,*) ' ERROR ON INPUT - PROGRAM STOPPED. ERROR=',  iswth
    WRITE(id_tabout,*) ' '
    STOP ' '
  END IF
  
!---      Otherwise the primary trajectory was read with no errors - the
!---      errors were in the stage cards.  Print a message but continue
!---      reading and processing.  The previous stages may have been
!---      correct and following stages may be correct.  This was done to
!---      prevent unnecessary interruption of long running jobs.
  WRITE(id_tabout,*) ' ERROR ON STAGE INPUT - CONTINUING PROCESSING...'
  
  WRITE(id_tabout,*) ' '
  
  WRITE(id_tabout,*) ' ERROR ON STAGE INPUT - CONTINUING PROCESSING...'
  
  WRITE(id_tabout,*) ' '
  
  GO TO 100
  
END IF


RETURN
END SUBROUTINE oinpt1

SUBROUTINE oin1_emsg( icardtype )

!-------------------------------------------------------------------------

!  Displays the error message for invalid input on the cards.

!--Argument List Definitions--------------------------------------------

!  ICARDTYPE - (I) Input.  The card type currently beingprocesIR(1) )

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: icardtype
COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /oindat/  j16, icd, i16


WRITE(id_tabout,880) icardtype, icd, j16
880 FORMAT( ' -INPUT ERROR, RUN ABORTED. IR(1)-ICD-J16 ', 3I4 )


RETURN

END SUBROUTINE oin1_emsg

SUBROUTINE oin1_init

!-------------------------------------------------------------------------

!  This module performs some variable initialization necessary at each
!  call to OINPT1

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /coller/ hol(5)
CHARACTER (LEN=80) :: hol

COMMON /krun/  jrun, mulrun, igroup

COMMON /stage/   loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest



!---  Clear the Hollerith (card type 9) data so that if more is read
!     during the next stage, the new data will be displayed.

DO i = 1, 5
  hol(i) = ' '
END DO

!     Initialize the Number of stage tests to 0.  Ntest will be set
!     by the C10_process module if a stage card is encountered at the
!     end of this stage.  If a card type 12 or 6 is encountered at
!     the end of this stage, then the test number will be properly
!     set and the stage module will skip the stage testing, thereby
!     executing the trajectory to the end.

ntest = 0


RETURN
END SUBROUTINE oin1_init

SUBROUTINE oin1_load( ir, mode, vr, alpha, mint )

!-------------------------------------------------------------------------

! This module transfers the card data from the working trajectory arrays
! into working variables.

!--Argument List Definitions--------------------------------------------

!  ALPHA(3) - (C6) Contains the character data from the input card
!             currently being processed. (1= cols 3:8, 2= cols 9:14,
!             3= 15:20 )
!  IR(2)    - (I) Contains the integer data from the input card that is
!             currently being processed. (1= cols 1:2;  2= cols 21:25 )
!  MODE     - (I) Contains an integer from the input card that is
!             currently being processed. (cols 26:30 )
!  VR(2)    - (R) Contains the real data from the input card that is
!             currently being processed. (1= cols 31:45, 2= cols 46:60 )
!  MINT     - (I) Contains the last integer data form the input card.

!--Local Variable Definition--------------------------------------------

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: ir(2)
INTEGER, INTENT(OUT)                     :: mode
REAL, INTENT(OUT)                        :: vr(2)
CHARACTER (LEN=1), INTENT(OUT)           :: alpha(3)
INTEGER, INTENT(OUT)                     :: mint

CHARACTER (LEN=1) :: *6


COMMON /oindat/  j16, icd, i16

COMMON /stage1/  istage, numstage

COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al

COMMON /wsetst/  ncdw(20), jtst(20,60), locst(20,60),  &
    modst(20,60), va1st(20,60), va2st(20,60), m2st(20,60)

COMMON /wsetstc/ alst(20,3,60)
CHARACTER (LEN=6) :: alst




100 CONTINUE


IF( j16 > 0 ) THEN
  
!         J16=1: Processing stage cards.  Load the data from the stage
!                arrays.
  
  IF( i16 <= 0   .AND.  ncdw(numstage) < 1 ) THEN
    
!             No stage cards for this stage - Reset to read cards from
!             the main trajectory arrays.
    
    j16 = 0
    GO TO 100
    
  ELSE
    
!             Increment stage card counter:
    
    i16 = i16 + 1
    
    IF( i16 <= ncdw( numstage )  ) THEN
      
!                 Not reached the end of the stage cards yet.  Load the
!                 data from the stage input data arrays.
      
      ir(1) = jtst(  numstage, i16)
      ir(2) = locst( numstage, i16)
      
      DO iz = 1, 3
        alpha(iz) = alst(numstage,iz, i16)
      END DO
      
      mode  = modst(numstage, i16)
      mint  = m2st( numstage, i16)
      vr(1) = va1st(numstage, i16)
      vr(2) = va2st(numstage, i16)
      
    ELSE
      
!                 Reached the last card in the stage.  Reset the J16
!                 flag and read the data from the main trajectory arrays.
      
      j16 = 0
      GO TO 100
      
    END IF
    
  END IF
  
  
ELSE
  
!         J16= 0: - load data from the main trajectory arrays.
  
!         Increment the card counter for the main trajectory arrays.
  
  icd = icd + 1
  
!         Transfer the data to the working arrays.
  
  ir(1) = jtype(icd)
  ir(2) = loca(icd)
  
  DO iz = 1, 3
    alpha(iz) = al(iz,icd)
  END DO
  
  mode  = moe(icd)
  mint  = m2( icd)
  vr(1) = va1(icd)
  vr(2) = va2(icd)
  
END IF


!     Go process card data.


RETURN
END SUBROUTINE oin1_load

SUBROUTINE oin1_process( iswth )

!-------------------------------------------------------------------------

!  This module loads the card data from the working arrays, and calls the
!  processing modules

!--Local Variable Definition--------------------------------------------

!  ALPHA(3) - (C6) Contains the character data from the input card
!             currently being processed. (1= cols 3:8, 2= cols 9:14,
!             3= 15:20 )
!  IR(2)    - (I) Contains the integer data from the input card that is
!             currently being processed. (1= cols 1:2;  2= cols 21:25 )
!  MODE     - (I) Contains an integer from the input card that is
!             currently being processed. (cols 26:30 )
!  VR(2)    - (R) Contains the real data from the input card that is
!             currently being processed. (1= cols 31:45, 2= cols 46:60 )

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: iswth
DIMENSION ir(2), vr(2)
CHARACTER (LEN=1) :: alpha(3)*6

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/    jrun, mulrun, igroup

COMMON /oindat/  j16, icd, i16

COMMON /stage1/  istage, numstage

140 CONTINUE


!     Load the card data from the arrays into working variables.

CALL oin1_load( ir, mode, vr, alpha, mint )


!     Start card processing:

IF( ir(1) > 89 ) THEN
  
!---      Card type 90 or 91: Mod to save and restore simulation state.
  
  CALL c90_process
  
  
ELSE IF( ir(1) == 1 ) THEN
  
!         Card type 1: Module selection cards of modules to be executed
!             After Each Integration Step.
  
  CALL c1_process( ir(2), iswth )
  
  
ELSE IF( ir(1) == 2 ) THEN
  
!         Card type 2:  Module selection cards.  These cards contain the
!         list of module numbers to be executed, in the order of execution.
  
  CALL c2_process( ir(2), iswth )
  
  
ELSE IF( ir(1) == 3 ) THEN
  
!         Card type 3 : Variable initialization Cards.
  
  CALL c3_process( ir(2), vr, mode, alpha(3), iswth )
  
  
ELSE IF( ir(1) == 4 ) THEN
  
  CONTINUE
  
  
ELSE IF( ir(1) == 5 ) THEN
  
!         Card type 5 : Number of trajectories to run.
  
  IF( mode < jrun ) THEN
    WRITE(id_tabout,*) ' ERROR ON TYPE 5 CARD '
    WRITE(id_tabout,*) ' Num of runs entered is invalid: ', mode
    iswth = 101
    RETURN
  END IF
  
  mulrun = mode
  
  
ELSE IF( ir(1) == 6 ) THEN
  
!         Card type 6 : end of primary trajectory.
  
!         Store stageing flag to remember why staged.
  
  istage = ir(1)
  
!         Go finish executing the trajectory.
  
  RETURN
  
  
ELSE IF( ir(1) == 7 ) THEN
  
  CALL c7_process( ir(2), mode, vr, numstage, iswth )
  
  
ELSE IF( ir(1) == 8 ) THEN
  
!         Card type 8 : Read and set up weather data.
!         Display the data to the output file also.
  
  CALL c8_process
  
  
ELSE IF( ir(1) == 9 ) THEN
  
!         Card type 9 : Text information
  
  CALL c9_process( ir(2) )
  
  
ELSE IF( ir(1) == 10 ) THEN
  
!         Card type 10: Conditions for staging
  
  CALL c10_process( ir(2), iswth )
  
  
ELSE IF( ir(1) == 11 ) THEN
  
!         Card type 11 -
  
  CALL c11_process( ir(2), alpha, vr, iswth, mode )
  
  
ELSE IF( ir(1) == 16 ) THEN
  
!---      End of stage criteria = start of a stage.  Continue the
!         trajectory until the stage criteria has been met then process
!         the cards from the stage arrays for this stage.
  
  j16 = 1    ! Set flag for loading from stage arrays.
  i16 = 0    ! Initialize stage card counter.
  
!         Store stageing flag to remember why staged.
  
  istage = ir(1)
  
!         Go process the trajectory until the stage criteria is met.
  
  RETURN
  
  
ELSE IF( ir(1) == 19 ) THEN
  
  CALL c19_process( ir(2), mode, vr, mint, iswth )
  
  
ELSE IF( ir(1) == 20 ) THEN
  
  CALL c20_process( ir(2), mode, vr, iswth )
  
  
ELSE IF( ir(1) == 21 ) THEN
  
  CALL  c21_process( ir(2), mode, vr, mint, iswth )
  
  
ELSE
  
!         Invalid card type entered.  Write the error message.
  
  iswth = 101
  CALL oin1_emsg( ir(1) )
  STOP ' '
  
  
END IF


!     Go process the next card.

GO TO 140


RETURN
END SUBROUTINE oin1_process

SUBROUTINE oin1_prtchk

!-------------------------------------------------------------------------

!  This module checks to see if the print/plot time intervals need to be
!  saved or adjusted after a batch of input cards have been processed.
!  If the trajectory is just being started, then the print interval save
!  variables need to be initialized.  If the trajectory has been
!  started, then check to see if the print intervals have been modified;
!  if so, then modify the next print time accordingly.

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /prev/    tprev, cpprev, ppprev


EQUIVALENCE (c(2000), time )
EQUIVALENCE (c(2003), pcnt )
EQUIVALENCE (c(2004), ppnt )
EQUIVALENCE (c(2005), ppp  )
EQUIVALENCE (c(2015), cpp  )



IF( time <= 0.0 ) THEN
  
!         The trajectory has not started yet.  Save the tabular print
!         rate.
  
  cpprev = cpp
  ppprev = ppp
  
ELSE
  
!         Integration has already begun.
  
  IF( cpp /= cpprev ) THEN
    
!             The current print rate is not the same as the previous
!             print rate;  the user has modified the print rate.
    
!             Estimate the next tabular print time by subtracting the
!             previous print interval then adding the new print
!             interval.
    
    pcnt = pcnt - cpprev + cpp
    
!             Insure that the next print time is greater than the
!             current time.
    
    DO WHILE ( pcnt < time  )
      
!                 Increase the next print time
      
      pcnt = pcnt + cpp
    END DO
    
!             Save the new print time interval
    
    cpprev = cpp
    
  END IF
  
  
  IF( ppp /= ppprev ) THEN
    
!             The plot interval has been modified.
!             Estimate the next plot print time by subtracting the
!             previous print interval then adding the new print
!             interval.
    
    ppnt = ppnt - ppprev + ppp
    
!             Insure that the next print time is greater than the
!             current time.
    
    IF( ppnt < time ) THEN
      
!                 Increase the next print time
      
      ppnt = ppnt + ppp
    END IF
    
!             Save the new print time interval
    
    ppprev = ppp
    
  END IF
  
END IF

RETURN
END SUBROUTINE oin1_prtchk

!-------------------------------------------------------------------------

SUBROUTINE op_start( nplotvar )

!-------------------------------------------------------------------------

!  This module writes the title and first header records to the output
!  file/display (unit 6)

!--Argument List Definitions-------------------------------------------

! NPLOTVAR - (I) Integer containing the number of variables input
!            selected for plotting on the HEADER file.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: nplotvar
COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /hcom/   title
CHARACTER (LEN=100) :: title

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /opsvar/ iscrol, kloc(16), lprt, iheadp, ints(16)
LOGICAL :: ints

COMMON /opflgc/ fmtstring, trace
CHARACTER (LEN=1) :: fmtstring*85, trace(16)*8

COMMON /firsti/ finit
LOGICAL :: finit

INTEGER :: getenvqq
CHARACTER (LEN=50) :: filename


!---  Open the file containing the input cards (35) CADIN.ASC

!------------------------Vax Code-------------------------------------

!     Check the filename then open the file:
!     Translate the logical name.  If the logical name is undefined, the
!     FILENAME variable is loaded with the name of the logical.

!      CALL LIB$SYS_TRNLOG( 'INDATA', LENGTH, FILENAME )

!      IF( FILENAME(1:LENGTH) .EQ. 'INDATA' ) THEN

!         A filename was not defined in the logical name:
!         Set the filename to the default:

!          FILENAME = 'FOR005.DAT'
!      ENDIF

!------------------------PC Code-------------------------------------

!---  Check to see if the filename for the input file CADIN.ASC
!---  was set using an enviroment variable.  If so, translate the
!---  environment variable. If the variable is undefined (the value of
!---  LENGTH is 0) set the file name to the default.
!---      LENGTH = get_environment_variable( 'CADIN', FILENAME )
length = 0
IF( length == 0 ) filename = 'cadin.ASC'

!---  Open the CADIN.ASC file.
!---      OPEN(UNIT=ID_CADIN, FILE = FILENAME(1:LENSTR(FILENAME)),
!---     1     STATUS='OLD', MODE='READ', ERR =999)
!---      OPEN(UNIT=ID_CADIN, FILE = 'CADIN.ASC' )
OPEN(UNIT=id_cadin, FILE = filename(1:lenstr(filename)) )




!---  Open the tabular output file (6)

id_tabout = 6
IF( tabout ) THEN
  
!---    Inform the user that the tabular output is being written to the
!---    file TABOUT.ASC.
  WRITE( *,'(//A)' )  &
      '* * * Tabular output is being written to file TABOUT.ASC * * *'
  
!---    Check to see if the filename for the input file TABOUT.ASC
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'TABOUT', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'tabout.ASC'
  
  OPEN( UNIT=id_tabout, FILE=filename(1:lenstr(filename)), STATUS='UNKNOWN' )
  
END IF

!--------------------------------------------------------------------

!---  Write the initial output to the tabular output file (6)
!---  Put a copy of the input cards to the output file/display
IF( inecho ) CALL sav_instream

!---  Add the current date and time to the title variable (cols 72-100)

!---  Read the title variable:
REWIND ( id_cadin )
READ(id_cadin, '(A)' ) title
REWIND ( id_cadin )


!---  Get the date and the time.
CALL dattim


!---  Display the title to the output device.
WRITE(id_tabout, '(1X,A)' ) title

!---  Write execution title to the screen if the output is going to a file.
IF( tabout ) WRITE(*, '(// 1X,A)' ) title


!---  Display the scroll variable acronyms : ie header for output data.
!---  In order to avoid a blank line after the acronyms when 10 scroll
!---  variables are selected, the last variable is written without
!---  following blanks.
IF( lprt == 10 )  THEN
  WRITE(id_tabout, '( 1X, 9A8, A )' )  &
      ( trace(ii),ii=1,lprt-1 ), trace(lprt)(1:lenstr(trace(lprt)))
ELSE IF( lprt > 0 ) THEN
  WRITE(id_tabout, '( 1X, 16A8 )' ) ( trace(ii),ii=1,lprt )
END IF


!---  Open the binary and ascii trajectory files files and write the
!---  header records if the files are to be created.

!---  Check to see if the binary trajectory file is to be created.
IF( trajbin ) THEN
  
!---    Check to see if the filename for the binary trajectory file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'TRAJBIN', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'traj.BIN'
  
!---    Open the binary trajectory file.
!---        OPEN( UNIT=ID_TRAJBIN, FILE = FILENAME(1:LENSTR(FILENAME)),
!---     1        STATUS='UNKNOWN', FORM='BINARY' )
!---        OPEN( UNIT=ID_TRAJBIN, FILE = 'TRAJ.BIN' )
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_trajbin, FILE = filename(1:lenstr(filename)) )
  
  
END IF


!---  Check to see if the ascii trajectory file is to be created.
IF( trajasc ) THEN
!cccccGAB the TRAJ.ASC file does not have the proper format for plotting..
!---    Check to see if the filename for the ascii trajectory file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'TRAJASC', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'traj.ASC'
  
!---    Open the binary statistics file.
!---        OPEN( UNIT=ID_TRAJASC, FILE = FILENAME(1:LENSTR(FILENAME)),
!---      1        STATUS='UNKNOWN', FORM='FORMATTED' )
!---            OPEN( UNIT=ID_TRAJASC, FILE = 'TRAJ.ASC' )
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_trajasc, FILE = filename(1:lenstr(filename)) )
  
END IF


!---  Open the binary and ascii statistics files files and write the
!---  header records if the files are to be created.
!------------------------PC Code-------------------------------------


!---  Check to see if the binary statistics file is to be created.
IF( statbin ) THEN
  
!---    Check to see if the filename for the binary statistists file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'STATBIN', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'stat.BIN'
  
!---    Open the binary statistics file.
!---        OPEN( UNIT=ID_STATBIN, FILE = FILENAME(1:LENSTR(FILENAME)),
!---     1        STATUS='UNKNOWN', FORM='BINARY' )
!---        OPEN( UNIT=ID_STATBIN, FILE = 'STAT.BIN' )
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_statbin, FILE = filename(1:lenstr(filename)) )
END IF


!---  Check to see if the ascii statistics file is to be created.
IF( statasc ) THEN
  
!---    Check to see if the filename for the ascii statistists file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'STATASC', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'stat.ASC'
  
!---    Open the binary statistics file.
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_statasc, FILE = filename(1:lenstr(filename)),  &
      STATUS='UNKNOWN', FORM='FORMATTED' )
  
END IF

!--- Check to see if RT CADAC files are to be created
!    added under XR Task 97 - Real-Time CADAC

!---  Check to see if the binary initialization file is to be created.
IF( initbin ) THEN
  
!---    Check to see if the filename for the binary statistists file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'INITBIN', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'init.BIN'
  
!---    Open the binary statistics file.
!---        OPEN( UNIT=ID_INITBIN, FILE = FILENAME(1:LENSTR(FILENAME)),
!---     1        STATUS='UNKNOWN', FORM='BINARY' )
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_initbin, FILE = filename(1:lenstr(filename)) )
  
!---           &STATUS='UNKNOWN', FORM='FORMATTED' )
  
!---    Set the First INIT write flag to true
  finit = .true.
  
END IF


!---  Check to see if the ascii initialization file is to be created.
IF( initasc ) THEN
  
!---    Check to see if the filename for the ascii initialization file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'INITASC', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'init.ASC'
  
!---    Open the binary initialization file.
!---        OPEN( UNIT=ID_INITASC, FILE = FILENAME(1:LENSTR(FILENAME)),
!---     1      STATUS='UNKNOWN', FORM='FORMATTED' )
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_initasc, FILE = filename(1:lenstr(filename)) )
  
  
!---    Set the First INIT write flag to true
  finit = .true.
  
END IF

!---  Check to see if the binary track data file is to be created.
IF( trackbin ) THEN
  
!---    Check to see if the filename for the binary track data file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!----        LENGTH = GETENVQQ( 'TRACKBIN', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'track.BIN'
  
!---    Open the binary track data file.
!---        OPEN( UNIT=ID_TRACKBIN, FILE = FILENAME(1:LENSTR(FILENAME)),
!---     1        STATUS='UNKNOWN', FORM='BINARY' )
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_trackbin, FILE = filename(1:lenstr(filename)) )
END IF


!---  Check to see if the ascii track data file is to be created.
IF( initasc ) THEN
  
!---    Check to see if the filename for the ascii track data file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'TRACKASC', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'track.ASC'
  
!---    Open the binary statistics file.
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_trackasc, FILE = filename(1:lenstr(filename)),  &
      STATUS='UNKNOWN', FORM='FORMATTED' )
  
END IF

CALL strt_plot( nplotvar )


!---  The output file of stocastic variable initial values (from
!---  type 3 card) has been requested.

IF( ranvar ) THEN
  
!---    Check to see if the filename for the binary statistists file
!---    was set using an enviroment variable.  If so, translate the
!---    environment variable. If the variable is undefined (the value of
!---    LENGTH is 0) set the file name to the default.
!---        LENGTH = GETENVQQ( 'RANVAR', FILENAME )
  length = 0
  IF( length == 0 ) filename = 'ranvar.ASC'
  
  PRINT *, 'FILENAME:', filename(1:lenstr(filename))
  OPEN( UNIT=id_ranvar, FILE=filename(1:lenstr(filename)),  &
      STATUS='UNKNOWN', FORM='FORMATTED' )
  
!---    Display the title to the output device.
  WRITE(id_ranvar, '(1X,A)' ) title
  
END IF


RETURN


!---  Input file open error statement:

999 CONTINUE


WRITE(id_tabout,*)
WRITE(id_tabout,*) ' *** ERROR OPENING LEAD CARD DECK: ', filename, '***'
WRITE(id_tabout,*)

STOP ' '
END SUBROUTINE op_start

SUBROUTINE oupt2

!-------------------------------------------------------------------------

!  This module is the initialization module for module OUPT3. ?

!-------------------------------------------------------------------------

COMMON      c(3510)

EQUIVALENCE (c(2016), pgcnt  )
EQUIVALENCE (c(2014), itcnt  )
EQUIVALENCE (c(2003), pcnt   )
EQUIVALENCE (c(2000), time   )
EQUIVALENCE (c(2004), ppnt   )


itcnt = 1
pgcnt = 1

pcnt  = time - 0.000001
ppnt  = pcnt


RETURN
END SUBROUTINE oupt2

SUBROUTINE oupt3( stagemet )

!-------------------------------------------------------------------------

!  This module controls data output.  If the SCROLL option has been
!  selected, this module prints the data to the appropriate output device,
!  displaying the header records at appropriate intervals.  This module
!  also controls the output to the plot files, printing the data
!  at the appropriate moments in the simulation.

!--Argument List Definitions--------------------------------------------

!  STAGEMET - (L) .True. - a stage condition has been met prior to
!             the module call.   .False. - called after modules to check
!             print times.

!-------------------------------------------------------------------------



LOGICAL, INTENT(IN OUT)                  :: stagemet


!---  Print the data to the tabular output file:
CALL op3_wr_tabout

!---  Write the TRAJ data:
CALL op3_11test

!---  Write the STAT data:
CALL op3_44plot( stagemet )


RETURN
END SUBROUTINE oupt3

SUBROUTINE op3_11test

!-------------------------------------------------------------------------

!  This module controls the writting to the TRAJ.*.  The data is
!  written at the user specified intervals

!-------------------------------------------------------------------------

COMMON    c(3510)

EQUIVALENCE (c(2000), time  )
EQUIVALENCE (c(2005), ppp   )
EQUIVALENCE (c(2004), ppnt  )
EQUIVALENCE (c(2020), lconv )


IF( ppp /= 0.0 ) THEN
  
!        The print interval is not 0.0, so test for printing to the plot
!        file.
  
  IF( lconv > 1 ) THEN
    
!            End of trajectory calculations.
!            Print the data to the plot files regardless of the print time.
    
    CALL op3_11write
    
!            Print data RT file if necessary
    
  ELSE IF( time >= ppnt ) THEN
    
!            Calculate the next plot print time.
!            Increment the plot print time.
    
    ppnt = ppnt + ppp
    ppnt = AMAX1( ppnt, time )
    
!            Print the to the plot files.
    
    CALL op3_11write
    
    
  END IF
END IF


RETURN
END SUBROUTINE op3_11test

SUBROUTINE op3_11write

!-------------------------------------------------------------------------

!  This module writes the selected plot variable data to the TRAJ.*.
!  The data is also tested to collect the minimum and maximum values.

!--Local Variable Definitions---------------------------------------------

!-------------------------------------------------------------------------

DIMENSION plotdata(70), ic(3510)

COMMON    c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/    jrun, mulrun, igroup

COMMON /opplot/  ipladd(70), intplot(70)
LOGICAL :: intplot


EQUIVALENCE (c(0001), ic(0001) )
EQUIVALENCE (c(2020), lconv    )
EQUIVALENCE (c(2280), nv       )


!---  Load the min/max arrays
CALL ld_minmax

!---  Insure that time is first.
ipladd(1) = 2000

!---  Determine the data to print to the TRAJ.* files.
DO i = 1, nv
  IF( intplot(i) ) THEN
    plotdata(i) = ic( ipladd(i) )
  ELSE
    plotdata(i) = c( ipladd(i) )
  END IF
END DO

IF( trajbin ) WRITE(id_trajbin)   ( plotdata(i), i=1,nv )
IF( trajasc ) WRITE(id_trajasc,*) ( plotdata(i), i=1,nv )


RETURN
END SUBROUTINE op3_11write

SUBROUTINE op3_44plot(  stagemet )

!-------------------------------------------------------------------------

!  This module controls the printing of the data to the STAT.* plot
!  file.

!--Argument List Definitions--------------------------------------------

!  STAGEMET - (L) .True. - a stage condition has been met prior to
!             the module call.   .False. - called after modules to check
!             print times.

!-------------------------------------------------------------------------


LOGICAL, INTENT(IN)                      :: stagemet


COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/   jrun, mulrun, igroup

COMMON /opplot/ ipladd(70), intplot(70)
LOGICAL :: intplot

COMMON          c(3510)

DIMENSION   ic(3510)

EQUIVALENCE (c(0001), ic(0001) )
EQUIVALENCE (c(2020), lconv )
EQUIVALENCE (c(2280), nv    )

DIMENSION plotdata(70)


!---  Write the STAT data:

IF( stagemet .OR.  lconv > 1 ) THEN
  
!---    If a stage criteria has been met OR the end of the trajectory
!---    has been reached, then write the data to the STAT.* file
  
  DO i = 1, nv
    IF( intplot(i) ) THEN
      plotdata(i) = ic( ipladd(i) )
    ELSE
      plotdata(i) = c( ipladd(i) )
    END IF
  END DO
  
  IF(statbin) WRITE(id_statbin)  (plotdata(i),i=1,nv),jrun,igroup
  IF(statasc) WRITE(id_statasc,*)(plotdata(i),i=1,nv),jrun,igroup
  
!---  At Dr. Zipfel's request, the code to create a tape45 was commented
!---  out. ( 29 Sep 1994.)
!          IF( LCONV .GT. 1 )
!     1        WRITE(45,*) ( PLOTDATA(I), I=1, NV )
  
  
END IF


RETURN
END SUBROUTINE op3_44plot

SUBROUTINE op3_rtwrite

!-------------------------------------------------------------------------

!  This module writes the selected plot variable data to the TRACK.*.

!--Local Variable Definitions---------------------------------------------

!-------------------------------------------------------------------------

DIMENSION plotdata(70), ic(3510)

COMMON    c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /optrack/  ipltrack(70), intptrack(70), ntrackvar
LOGICAL :: intptrack

COMMON /optrackc/ tracklab
CHARACTER (LEN=1) :: tracklab(70)*8

EQUIVALENCE (c(0001), ic(0001) )


!---  Insure that time is first.
ipltrack(1) = 2000

!---  Determine the data to print to the TRAJ.* files.
DO i = 1, ntrackvar
  IF( intptrack(i) ) THEN
    plotdata(i) = ic( ipltrack(i) )
  ELSE
    plotdata(i) = c( ipltrack(i) )
  END IF
END DO

IF( trackbin ) WRITE(id_trackbin) (plotdata(i), i=1,ntrackvar)
IF( trackasc ) WRITE(id_trackasc,*) (plotdata(i), i=1,ntrackvar)


RETURN
END SUBROUTINE op3_rtwrite

SUBROUTINE op3_wr_tabout

!-------------------------------------------------------------------------

!  This module writes the selected scroll data to the tabular output at
!  the user selected/requested print rates.

!--Local Variable Definitions---------------------------------------------

!-------------------------------------------------------------------------


COMMON         c(3510)

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/    jrun, mulrun, igroup

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /opsvar/  iscrol, kloc(16), lprt, iheadp, ints(16)
LOGICAL :: ints

COMMON /opflgc/ fmtstring, trace
CHARACTER (LEN=1) :: fmtstring*85, trace(16)*8

DIMENSION   der(101), ic(3510)

EQUIVALENCE (c(0001), ic(0001) )
EQUIVALENCE (c(1801), critno )
EQUIVALENCE (c(1805), critmax )
EQUIVALENCE (c(2000), time )
EQUIVALENCE (c(2003), pcnt )
EQUIVALENCE (c(2015), cpp  )
EQUIVALENCE (c(2020), lconv  )
EQUIVALENCE (c(2664), der(1)  )


DIMENSION plotdata(70)


IF( iscrol > 0 ) THEN
  
!         Scroll is entered on the HEADER file.  Print output as
!         selected.
  
  IF( jrun < 2 )   THEN
    
!             This is the first trajectory of a set.  Check to see
!             if should print data out.  Only print the time trajectory
!             data for the first run of a monte carlo/multirun set.
!             Don't print trajectories at other JRUN runs.
!             These  IF statements could
!             be combined, however separated hoping to keep execution
!             time minimal.  Perform simple test at each call then
!             when get this criteria, perform more complex test.
    
    IF( .NOT. xsweep .OR. ( xsweep .AND. igroup < 2 ) ) THEN
      
!              The case is NOT a sweep run   OR   the case is a sweep run
!              and this is the first group/aimpoint
      
      IF( time >= pcnt ) THEN
        
!                  The time is greater than the print time.  Print the
!                  data now.   Start by incrementing the line counter
!                  to determine when the headers need to be printed.
        
        iheadp = iheadp + 1
        
        IF( iheadp > 10 ) THEN
          
!---                   10 lines printed since last header display.  Print
!---                   header display now. In order to avoid a blank line
!---                   after the acronyms when 10 scroll variables are
!---                   selected, the last variable is written without
!---                   following blanks.
          IF( lprt == 10 )  THEN
            WRITE(id_tabout, '( 1X, 9A8, A )' ) ( trace(ii),ii=1,lprt-1 ),  &
                trace(lprt)(1:lenstr(trace(lprt)))
          ELSE IF( lprt > 0 ) THEN
            WRITE(id_tabout, '( 1X, 16A8 )' ) ( trace(ii),ii=1,lprt )
          END IF
          
          iheadp = 0      ! Reset Counter
          
        END IF
        
        IF( lprt > 0 ) THEN
          DO i = 1, lprt
            IF( ints(i) ) THEN
              plotdata(i) = ic( kloc(i) )
            ELSE
              plotdata(i) = c( kloc(i) )
            END IF
          END DO
        END IF
        
!---               Print the data
        IF( lprt > 0 ) WRITE(id_tabout,FMT=fmtstring) (plotdata(i),i=1,lprt)
        
!---               Calculate a test time for the next tabular data print.
!---               Allow a margin of error in case the Time is not exact
!---               due to (?) computer numeric representation ?
        
        num_interval = AINT( ( time + 0.5 * der(1) ) / cpp + 1.0 )
        pcnt = num_interval * cpp - 0.5 * der(1)
        
!---               Print the Real-Time TRACK data
        CALL op3_rtwrite
        
      END IF
      
    END IF
  END IF
  
END IF


IF( lconv == 2 ) THEN
  
!         Lconv = 2 =  End of trajectory either by PCA or by
!         impact.  Write a message to the output file.
  
  icritno = critno
  critvar = c( icritno )
  WRITE(id_tabout,100) c(2000), critvar, jrun, mulrun, igroup
  100     FORMAT( ' FLT TIME = ', g10.3, ' CRIT VAR = ', g10.3,  &
      ' RUN ', i3, ' OF ', i3, ' RUNS  IN  GROUP', i3)
  WRITE(id_tabout,*)
  
ELSE IF( lconv > 2 ) THEN
  
!         Lconv > 2 = trajectory did not reach correct end
  
  icritno = critno
  critvar = critmax
  WRITE(id_tabout,100) c(2000), critvar, jrun, mulrun, igroup
  WRITE(id_tabout,*)
END IF


RETURN
END SUBROUTINE op3_wr_tabout

SUBROUTINE op3_pf11( iunit )

!-------------------------------------------------------------------------

!  This module writes the -1.0 record to either the TRAJ.* or STAT.*
!  plot file for separating sets of multiple/sweep trajectory data.

!--Argument List Definitions--------------------------------------------

!  IUNIT - (I) The unit number of the unit to be written to.

!-------------------------------------------------------------------------



INTEGER, INTENT(IN OUT)                  :: iunit
COMMON           c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/    jrun, mulrun, igroup

DIMENSION   pmin(70)


EQUIVALENCE (c(2127), pmin(1) )
EQUIVALENCE (c(2280), nv    )


pmin(1) = -1.0

IF( iunit == id_trajbin ) THEN
  
!---      Write a -1.0 record to the binary trajectory file.
  WRITE( iunit )    ( pmin(i), i=1, nv )
  
ELSE IF( iunit == id_trajasc ) THEN
  
!---      Write a -1.0 record to the ascii trajectory file.
  WRITE( iunit, * ) ( pmin(i), i=1, nv )
  
ELSE IF( iunit == id_statbin ) THEN
  
!---      Write a -1.0 record to the binary statistics file.
  WRITE( iunit )    ( pmin(i), i=1, nv ), jrun, igroup
ELSE
  
!---      Write a -1.0 record to the ascii statistics file.
  WRITE( iunit, * ) ( pmin(i), i=1, nv ), jrun, igroup
  
END IF


RETURN
END SUBROUTINE op3_pf11

SUBROUTINE sweepi

!-------------------------------------------------------------------------

!  This module calls the SWEEP methodologies as directed by type 19, 20,
!  and 21 cards.  A SWEEP run is indicxated when the SWEEP flag is set in
!  the HEAD.ASC header file.

!---SWEEP Methodoligies---------------------------------------------------

!  Mode 0: Constant Delta                                ISWEEP = 0
!  Mode 1: Increasing Range in Decreasing Step Size      ISWEEP = 1
!  Mode 2: Decreasing Range in Increasing Step Size      ISWEEP = 2
!  Mode 3: Increasing/Decreasing Step Size               ISWEEP = 3
!  Mode 4: Outer Boundary Test                           ISWEEP = 4
!  Mode 5: All Boundary Test                             ISWEEP = 5

!-------------------------------------------------------------------------

COMMON c(3510)

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

DIMENSION ksee(3510)

EQUIVALENCE (c(0001), ksee(1) )
EQUIVALENCE (c(1800), isweep )

IF( xsweep ) THEN
  
!---  CALL SWEEP METHODOLOGIES
  
  IF(isweep == 5) THEN
    
!---       SWEEP Methodology 5: ALL BOUNDARY TEST
    CALL sweep5_method
    
  ELSE IF(isweep == 4) THEN
    
!---       SWEEP Methodology 4: OUTER BOUNDARY TEST
    CALL sweep4_method
    
  ELSE IF(isweep == 3) THEN
    
!---       SWEEP Methodology 3: INCREASING/DECREASING STEP SIZE
    CALL sweep3_method
    
  ELSE IF(isweep == 2) THEN
    
!---       SWEEP Methodology 2: DECREASING RANGE IN INCREASING STEP SIZE
    CALL sweep2_method
    
  ELSE IF(isweep == 1) THEN
    
!---       SWEEP Methodology 1: INCREASING RANGE IN DECREASING STEP SIZE
    CALL sweep1_method
    
  ELSE IF(isweep == 0) THEN
    
!---       SWEEP Methodology 0: CONSTANT DELTA
    CALL sweep0_method
    
  END IF
  
END IF

RETURN
END SUBROUTINE sweepi

FUNCTION rayleigh( sig )

!-----------------------------------------------------------------------

!    RAYLEIGH = X E**-( X**2 / SIG**2 *2 ) / SIG ** 2

!    MEAN = SIG * SQRT( PI / 2 )

!    VARIANCE = SIG**2 * ( 2 - PI / 2 )

!    RAYDEV ~ RAYLEIGH( SQRT(PI/2), (2-PI/2) )

!    Multiplying by sigma gives a mean of SIG*SQRT(PI/2) and a
!    variance of SIG**2 ( 2-PI/2 )

!-----------------------------------------------------------------------

rayleigh = raydev() * sig

RETURN
END FUNCTION rayleigh

!-----------------------------------------------------------------------

FUNCTION raydev()

!-----------------------------------------------------------------------

!     RAYDEV - function to generate a random variable with a
!              RAYLEIGH distribution with a mean and variance
!              of ( SQRT(PI/2), (2-PI/2) ) using a uniform random
!              function with a mean of (0,1).

!            ( returns a RAYLEIGH distributed, positive, random
!              deviate of PI/2 mean and (2-PI/2) using RANF() as
!              the source of uniform deviates )

!     The deviate is found by finding the inverse of the indefinate
!     integral of the pdf. ie. If the pdf is given by f(y), the
!     indefinate integral of f(y) is F(y).  The deviate is then the
!     inverse of F(y).

!      The Rayleigh is:

!         ( X / alpha**2 ) * exp( - X**2 / ( 2 * alpha**2) )

!      With an alpha of 1, we get:

!         X * exp( - X**2 / 2 )

!      The indefinite integral is:

!        exp( -X**2 / 2 )

!      The inverse is then:

!         SQRT( -2 * LN(Y) )

!      Where y is a uniformly distributed random variable.


!      For an indepth discussion of finding the deviate of a distribution
!      refer to Numerical Recipes: The Art of Scientific Computing by
!      Press, Flannery, Teukolsky, and Vetterling.

!-----------------------------------------------------------------------

raydev = SQRT( 2.0 * ( - 1.0 * ALOG( ranf() )  ) )

RETURN
END FUNCTION raydev
!---NOTE: This FUNCTION was included in the UTL.FOR file (and commented out here)
!         to remove an error that occurred during the execution of the RT CADAC model.
!         [BC 28 May 98]
!BC      REAL*4  FUNCTION RANF()            !  "Subroutine"

!-------------------------------------------------------------------------

!   This module generates a uniform random variable between 0 and 1,
!   exclusive of both 0 and 1.  This module was written because the
!   ranf function normally supplied with uVax and Vax systems was
!   generating an overflow error when passed valid seeds.  This module
!   also allows the user's to program modules requiring RANF but they
!   do not require access to the seed and this prevents them from
!   un-intentionally modifing the seed.

!-------------------------------------------------------------------------

!BC      CALL RANDOM( RVALUE )

!---  MS's RANDOM subroutine generates values >= 0 and < 1, 0-inclusive.
!BC
!BC      DO WHILE( RVALUE .EQ. 0.0 )
!BC         CALL RANDOM( RVALUE )
!BC      ENDDO

!BC      RANF = RVALUE


!BC      RETURN
!BC      END

SUBROUTINE rdh1_headr( nplotvar )

!-------------------------------------------------------------------------

!  This module opens the Head.ASC input file, determines if the user
!  has entered scroll or noscroll; if scroll is selected, the scroll
!  variables and format are determined; then the plot variable list is read
!  from the file.

!--Argument List Definitions-------------------------------------------

!  NPLOTVAR - (I) Output. Counts the number of variables as they are
!             added to the plot list.  Used in EXEC to initialize the
!             common location for each run.

!--Local Variable Definitions-------------------------------------------

!  INLINE - (80) An 80 character string used to read a record from the
!           Head.ASC file.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: nplotvar
COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opsvar/  iscrol, kloc(16), lprt, iheadp, ints(16)
LOGICAL :: ints


INTEGER :: getenvqq
CHARACTER (LEN=50) :: filename chara ter*150 inline



!---  Initialize variables.

iheadp = 0     ! Output line counter for placing header lines

!---  Open and start processing the Head.ASC file.

!---  Check to see if the filename for the input file HEAD.ASC
!---  was set using an enviroment variable.  If so, translate the
!---  environment variable. If the variable is undefined (the value of
!---  LENGTH is 0) set the file name to the default.
!---      LENGTH = GETENVQQ( 'HEAD', FILENAME )
length = 0
IF( length == 0 ) filename = 'head.ASC'

!---  Open the head.asc file.
!---      OPEN( UNIT=ID_HEAD, FILE = FILENAME( 1: LENSTR(FILENAME) ),
!---     1      STATUS='OLD', ERR=999, MODE='READ' )
OPEN( UNIT=id_head, FILE = 'HEAD.ASC' )

!---  Read the first line of the Head.ASC and determine whether the
!---  word SCROLL or NOSCROLL is included on the record.
!---  This determines whether the data is scrolled during CADAC
!---  execution on the terminal screen or not scrolled.

READ(id_head,100) inline
100 FORMAT(a)


CALL str_upcase( inline, inline )

!-------------------------------------------------

!---  Determine if the input is to be echoed on the output or not.
!---  Set the flag accordingly.
inecho = .false.
ifound = INDEX( inline, 'NOECHOIN' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'ECHOIN' )
  IF( ifound > 0 ) inecho = .true.
END IF


!---  Determine if staging messages are to be echoed on the output or not.
!---  Set the flag accordingly.
stgmsgout = .false.
ifound = INDEX( inline, 'NOSTGMSG' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'STGMSG' )
  IF( ifound > 0 ) stgmsgout = .true.
END IF

!---  Determine if the Integration messages are to be echoed on the
!---  output or not.  Set the flag accordingly.
intmsg = .false.
ifound = INDEX( inline, 'NOINTMSG' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'INTMSG' )
  IF( ifound > 0 ) intmsg = .true.
END IF

!---  Determine if a binary trajectory file is to be created.
trajbin = .false.
ifound = INDEX( inline, 'NOTRAJBIN' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'TRAJBIN' )
  IF( ifound > 0 ) trajbin = .true.
END IF

!---  Determine if an ASCII trajectory file is to be created.
trajasc = .false.
ifound = INDEX( inline, 'NOTRAJASC' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'TRAJASC' )
  IF( ifound > 0 ) trajasc = .true.
END IF

!---  Determine if an binary statistics file is to be created.
statbin = .false.
ifound = INDEX( inline, 'NOSTATBIN' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'STATBIN' )
  IF( ifound > 0 ) statbin = .true.
END IF

!---  Determine if an ASCII statistics file is to be created.
statasc = .false.
ifound = INDEX( inline, 'NOSTATASC' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'STATASC' )
  IF( ifound > 0 ) statasc = .true.
END IF

!---  Determine if an ASCII RT initialization file is to be created.
initasc = .false.
ifound = INDEX( inline, 'NOINITASC' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'INITASC' )
  IF( ifound > 0 ) THEN
    IF( .NOT. initbin ) initasc = .true.
  END IF
END IF

!---  Determine if an binary RT initialization file is to be created.
initbin = .false.
ifound = INDEX( inline, 'NOINITBIN' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'INITBIN' )
  IF( ifound > 0 ) THEN
    IF( .NOT. initasc ) initbin = .true.
  END IF
END IF

!---  Determine if an ASCII RT track data file is to be created.
trackasc = .false.
ifound = INDEX( inline, 'NOTRACKASC' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'TRACKASC' )
  IF( ifound > 0 ) THEN
    IF( .NOT. trackbin ) trackasc = .true.
  END IF
END IF

!---  Determine if an binary RT track data file is to be created
trackbin = .false.
ifound = INDEX( inline, 'NOTRACKBIN' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'TRACKBIN' )
  IF( ifound > 0 ) THEN
    IF( .NOT. trackasc ) trackbin = .true.
  END IF
END IF

!---  Determine if the tabular output is written to the screen (TABOUT=F)
!---  or to a file (TABOUT=T)
tabout = .false.
ifound = INDEX( inline, 'NOTABOUT' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'TABOUT' )
  IF( ifound > 0 ) tabout = .true.
END IF

!---  Determine if the Random data assigned to variables by the type 3
!---  and 11 cards are to be displayed to the RANSEL data file (unit 37)
!---  Set the flag accordingly.
ranvar = .false.
ifound = INDEX( inline, 'NORANVAR' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'RANVAR' )
  IF( ifound > 0 ) ranvar = .true.
END IF

!---  Determine if a SWEEP run will be executed
xsweep = .false.
ifound = INDEX( inline, 'NOSWEEP' )
IF( ifound == 0 ) THEN
  ifound = INDEX( inline, 'SWEEP' )
  IF( ifound > 0 ) xsweep = .true.
END IF

!---  Determine if the output is to be generated or suppressed.
ifound = INDEX( inline, 'NOSCROLL' )

IF( ifound > 0 ) THEN
  
!---      "Noscroll" was on the header record.
  iscrol = 0    ! Set the scroll flag = null.
  lprt   = 0    ! Number of scroll variables.
  
ELSE
  
!---      "Scroll" or neither keyword was on the first record of header.
  iscrol = 1
  CALL rdh1_scroll
  
END IF


!---  Read the list of variables to print to the TRAJ.*/STAT.* files.
CALL rdh1_pvar( nplotvar )


!---  Close the Head.ASC file.
CLOSE(id_head)

!---  End of the module.
RETURN


!---  Open statement error messages:
999 CONTINUE

WRITE(id_tabout,*) '  '
WRITE(id_tabout,*) ' *** Could not open HEAD.ASC data file ***'
WRITE(id_tabout,*) '  '

STOP
END SUBROUTINE rdh1_headr

SUBROUTINE rdh1_scroll

!-------------------------------------------------------------------------

!  This module reads the scroll variable list from the Head.ASC file.

!--Local Variable Definitions-------------------------------------------

!  ASKE    - (C1) The first character of the Head.ASC records - used to
!            check if an asterisk is punched in column 1.
!  FORSCROL- (C1) If non-blank, contains an integer indicating the number
!            of digits to the right of the decimal to use in the format
!            statment when writting this variable.  If "I" or " ", prints
!            the variable with 0 digits to the right of the decimal.
!  IFORMAT - (I) Integer value of the character in FORSCROL.
!  I1      - (I) Pointer into the format character string, FMTSTRING,
!            prior to adding the current scroll variable's format
!  I2      - (I) Pointer into the format character string, FMTSTRING, after
!            the addition of the current scroll variable's format.

!-------------------------------------------------------------------------

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opsvar/  iscrol, kloc(16), lprt, iheadp, ints(16)
LOGICAL :: ints

COMMON /opflgc/  fmtstring, trace
CHARACTER (LEN=1) :: fmtstring*85, trace(16)*8


CHARACTER (LEN=1) :: aske chara ter*1 forscrol


!     Initialize variables for determing the scroll variables
!     and their format.

fmtstring = '  '
fmtstring(1:1) = '('
i1 = 2             ! Initialize format pointer 1.
i2 = i1 + 4        ! Initialize format pointer 2.

lprt = 0           ! Number of scroll variables.


!---  Start of the loop for reading the variables:
160 CONTINUE

!---    Increment the scroll variable counter:
lprt = lprt + 1

!---    Read the next HEAD.ASC record.
READ(id_head,180) aske, forscrol, kloc(lprt), trace(lprt)
180   FORMAT( a1, 1X, a1, 1X, i4, 4X, a8 )


!---    Initialize the integer flag to indicate a real variable.
ints( lprt ) = .false.

IF( aske == '*' ) THEN
  
!---        The first character is an asterisk, the end of the
!---        scroll records has been reached.  Stop reading the
!---        scroll variables.  Adjust the scroll variables counter.
  lprt = lprt - 1
  
ELSE
  
!           Check for the integer scale value:
  
  IF( forscrol == 'i') THEN
    
!               Integer variable:  Set the flag in the array and
!               print this variable with 0 digits to the right of
!               the decimal.
    
    IF( lprt > 1 ) THEN
      fmtstring(i1:i2) = 'F8.0' // ','
    ELSE
      fmtstring(i1:i2) = 'F7.0' // ','
    END IF
    ints( lprt ) = .true.
    
  ELSE IF( forscrol == ' ') THEN
    
!               Print this variable with 0 digits to the right of the
!               decimal.
    
    IF( lprt > 1 ) THEN
      fmtstring(i1:i2) = 'F8.0' // ','
    ELSE
      fmtstring(i1:i2) = 'F7.0' // ','
    END IF
    
  ELSE
    
    READ( forscrol, '(I1)', ERR = 200 ) iformat
!VAX                  READ( FORSCROL, *, ERR = 200 ) IFORMAT
    GO TO 220
    
    200           CONTINUE
    
!                   Error occurred during read of format character.
    
    forscrol = '5'
    iformat = 5
    
    
    220           CONTINUE
    
    IF( iformat < 0  .OR.  iformat > 5 ) THEN
      forscrol = '5'
      iformat = 5
    END IF
    
!               Print the real variable with the number of significant
!               digits specified by the input file.
    
    IF( lprt > 1 ) THEN
      fmtstring(i1:i2) = 'F8.' // forscrol // ','
    ELSE
      fmtstring(i1:i2) = 'F8.' // forscrol // ','
    END IF
    
  END IF
  
!           Update pointers into the format character variable.
  
  i1 = i2 + 1
  i2 = i1 + 4
  
!           Continue this loop until 16 scroll variables have been read.
  
  IF( lprt < 16 ) GO TO 160
  
END IF

!---  End of scroll variables or reached the maximum allowed.

!     Finish the format statement for the scroll variables.
!     NOTE: Write over the comma inserted after the last added format
!     descriptor.

fmtstring( i1-1 : i1 ) = ') '


RETURN
END SUBROUTINE rdh1_scroll

SUBROUTINE rdh1_pvar( nplotvar )

!-------------------------------------------------------------------------

!  This module reads the parameter definitions list and loads the array
!  with the variable numbers to be printed to the TRAJ.*/STAT.* files.
!  The variables are marked for inclusion in the plot files by placing a
!  space in column 1 and an asterisk in column 2.

!--Argument List Definitions-------------------------------------------

!  NPLOTVAR - (I) Output. Counts the number of variables as they are
!             added to the plot list.  Used in EXEC to initialize the
!             common location for each run.

!--Local Variable Definitions-------------------------------------------

!  ASKE    - (C1) The first character of the Head.ASC records - used to
!            check if an asterisk is punched in column 1.
!            Also used to see if the variable is to be written to a
!            RT CADAC file: INIT.*/TRACK.* (implemented under task
!            XR 97 - Real-Time CADAC.)
!  KPL     - (I) Global common C location of the scroll variable as read
!            from the parameter definitions list.
!  ALA     - (C8) Variable parameter name (acronym) as read from the
!            parameter definitions list.
!  FORMAT  - (C1) A character variable read from the head.ASC record.
!            If 'I', indicates that the variable is an integer;
!            otherwise, it is a real.


!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: nplotvar
COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opplot/  ipladd(70), intplot(70)
LOGICAL :: intplot

COMMON /oppltc/  alable
CHARACTER (LEN=1) :: alable(70)*8

COMMON /opinit/  iplinit(70), intpinit(70), ninitvar
LOGICAL :: intpinit

COMMON /opinitc/ initlab
CHARACTER (LEN=1) :: initlab(70)*8

COMMON /optrack/  ipltrack(70), intptrack(70), ntrackvar
LOGICAL :: intptrack

COMMON /optrackc/ tracklab
CHARACTER (LEN=1) :: tracklab(70)*8

CHARACTER (LEN=8) :: ala
CHARACTER (LEN=1) :: FORMAT
CHARACTER (LEN=1) :: aske chara ter*80 inline


!---  Initialize the plot variable storage counter and arrays.  Always
!---  include TIME( = C(2000) ) as the first variable on the plot file.
nplotvar = 1
ipladd(1) = 2000
alable(1) = 'TIME    '

ninitvar = 1    ! Number of initialization variables
ntrackvar = 1   ! Number of track data file variables
iplinit(1) = 2000
ipltrack(1) = 2000
initlab(1) = 'TIME    '
tracklab(1) = 'TIME    '

!---  Read the parameter definitions list.  These cards must start with
!---  a blank in column 1.  Search through the list to find the
!---  variables that must be placed in the plot file.  The search
!---  continues until 70 variables have been found or the EOF is reached.

!---  Read past any comment records until the parameter definitions
!---  list is reached.
READ(id_head,100) inline
DO WHILE( inline(1:1) == '*' )
  READ(id_head,100) inline
END DO


!---  A plot variable definition has been found process the data.
60 CONTINUE

!--- Changed this test for valid record to NE '*' since a T, I, or B in
!    column 1 is a valid record.  This indicates output to the RT CADAC
!    Track data file, Initialization file, or Both.  Implemented under
!    task XR97 - Real-Time CADAC
IF( inline(1:1) /= '*') THEN
!---      A valid card has been found.  Read the data from the card.
  
  READ( inline(2:80), 280 ) aske, FORMAT, kpl, ala
  280     FORMAT( a1, a1, 1X, i4, 4X, a8 )
  
  IF( inline(1:1) == 'b' .OR. inline(1:1) == 'b' ) THEN
    IF( ninitvar > 69 ) inline(1:1) = 't'
    IF( ntrackvar > 69 ) inline(1:1) = 'i'
  END IF
  
  
  IF( aske == '*' ) THEN
    
!---              The second column of the card contained an asterisk.
!---              Capture this parameter for plotting.
    IF( kpl /= 2000 ) THEN
      
!---                  The selected variable is not the TIME ( C(2000) )
!---                  variable which has already been added to the list.
!---                  So add this variable to the list for plotting.  Save
!---                  the label also.
      nplotvar = nplotvar + 1
      ipladd( nplotvar ) = kpl
      alable( nplotvar ) = ala
      
!---                  Set the integer flag array to indicate which plot
!---                  variables are integers.
      IF( FORMAT == 'i' ) THEN
        intplot( nplotvar ) = .true.
      ELSE
        intplot( nplotvar ) = .false.
      END IF
      
    END IF
    
!---              Check if the maximum number of plot variables has been
!---              reached.  Once 70 variables are listed, end the search
!---              for plot variables.
    IF( nplotvar > 69 ) RETURN
    
  END IF
  
END IF
IF( inline(1:1) == 'i' .OR. inline(1:1) == 'i' ) THEN
  
!---          This variable is to be written to the RT initialization file
  IF( kpl /= 2000 ) THEN
    
!---                  The selected variable is not the TIME ( C(2000) )
!---                  variable which has already been added to the list.
!---                  So add this variable to the list for plotting.  Save
!---                  the label also.
    ninitvar = ninitvar + 1
    iplinit( ninitvar ) = kpl
    initlab( ninitvar ) = ala
    
!---                  Set the integer flag array to indicate which plot
!---                  variables are integers.
    IF( FORMAT == 'i' ) THEN
      intpinit( ninitvar ) = .true.
    ELSE
      intpinit( ninitvar ) = .false.
    END IF
    
  END IF
  
!---              Check if the maximum number of plot variables has been
!---              reached.  Once 70 variables are listed, end the search
!---              for plot variables.
  IF( ninitvar > 69 ) RETURN
  
ELSE IF( inline(1:1) == 'T' .OR.  &
      inline(1:1) == 't' ) THEN
  
!---          This variable is to be written to the RT track data file
  IF( kpl /= 2000 ) THEN
    
!---                  The selected variable is not the TIME ( C(2000) )
!---                  variable which has already been added to the list.
!---                  So add this variable to the list for plotting.  Save
!---                  the label also.
    ntrackvar = ntrackvar + 1
    ipltrack( ntrackvar ) = kpl
    tracklab( ntrackvar ) = ala
    
!---                  Set the integer flag array to indicate which plot
!---                  variables are integers.
    IF( FORMAT == 'i' ) THEN
      intptrack( ntrackvar ) = .true.
    ELSE
      intptrack( ntrackvar ) = .false.
    END IF
    
  END IF
  
!---              Check if the maximum number of plot variables has been
!---              reached.  Once 70 variables are listed, end the search
!---              for plot variables.
  IF( ntrackvar > 69 ) RETURN
  
ELSE IF( inline(1:1) == 'B' .OR.  &
      inline(1:1) == 'b' ) THEN
  
!---          This variable is to be written to the RT initialization and
!             track data file
  IF( kpl /= 2000 ) THEN
    
!---                  The selected variable is not the TIME ( C(2000) )
!---                  variable which has already been added to the list.
!---                  So add this variable to the list for plotting.  Save
!---                  the label also.
    ninitvar = ninitvar + 1
    iplinit( ninitvar ) = kpl
    initlab( ninitvar ) = ala
    
    ntrackvar = ntrackvar + 1
    ipltrack( ntrackvar ) = kpl
    tracklab( ntrackvar ) = ala
    
!---                  Set the integer flag array to indicate which plot
!---                  variables are integers.
    IF( FORMAT == 'i' ) THEN
      intpinit( ninitvar ) = .true.
      intptrack( ntrackvar ) = .true.
    ELSE
      intpinit( ninitvar ) = .false.
      intptrack( ntrackvar ) = .false.
    END IF
    
  END IF
  
!---              Check if the maximum number of plot variables has been
!---              reached.  Once 70 variables are listed, end the search
!---              for plot variables.
  IF( ninitvar > 69 .AND. ntrackvar > 69 ) RETURN
  
END IF

!---  Read the next record and continue processing the records,
!---  searching for the variable to be placed in the plot file.
READ(id_head,100,END=340) inline
100 FORMAT(a)

!---  Go process the record.
GO TO 60


!---  End of the search for plot variables.
340 CONTINUE


RETURN
END SUBROUTINE rdh1_pvar

SUBROUTINE rdi1_init_cards

!-------------------------------------------------------------------------

!  This module rewinds the input file (unit 35); performs reads to the
!  file and acquires the primary trajectory data (all cards until the
!  first type 6 or 12 card.  The input data is stored into the storage
!  arrays until it is ready to be processed by other modules.

!--Local Variable Definitions-------------------------------------------

!  NTEST - (I) Number of test cards following a type 10 card: Either 1
!          or 2.  There must be at least 1 stage card following the type
!          10 card but NTEST may be blank/zero for this case.

!-------------------------------------------------------------------------

COMMON c(3510)

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al

COMMON /nad/     ibeen, ibegin, icard, isave




!---  Start reading the input cards from the input card deck (35)
!---  and read them until the first card type 6 or 12 is detected.
!---  The input tape is rewound and the primary trajectory data is
!---  read.
CALL rdi1_prim_traj


IF( xsweep ) RETURN


ii = 1
IF( isave >= 1 ) ii = icard

DO i = ii, ncard
  
  IF( jtype(i) == 9 )  THEN
    
!---      Card type 9, write the header cards to output.
    numhol = loca(i)
    WRITE(id_tabout,'(1X,A80)') (holl(n),n=1,numhol)
    
  END IF
  
END DO


RETURN
END SUBROUTINE rdi1_init_cards

SUBROUTINE rdi1_prim_traj

!-------------------------------------------------------------------------

!  This module reads the input card deck (35) until the first card of
!  type 6 or 12 is reached.  These cards are stored into the arrays:
!  JTYPES, MODS, LOCS, etc.  This data will be utilized for each traj
!  calculation.

!--Local Variable Definitions-------------------------------------------

!  EOF_RCHD - (L) Indicates when the end of file has been reached.
!  ICRD     - (I) A card counter for the number of initialization cards
!                 read from the input file (35)
!  NSTG     - (I) The number of stages found in the initialization card
!                 deck.

!-------------------------------------------------------------------------

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /hcom/    title
CHARACTER (LEN=100) :: title

COMMON /ipsav/   ncards, nhol, jtypes(500), locs(500), mods(500),  &
    va1s(500), va2s(500), mod2(500)

COMMON /ipsavc/  als(3,500), hols(5)
CHARACTER (LEN=80) :: hols chara ter*6 als

COMMON /ipsvsc/  mcris(20,2,4), vals(20,2)

COMMON /ipsvscc/ mcrisc(20,2,2)
CHARACTER (LEN=6) :: mcrisc

COMMON /ipsvwd/  nwx, wxs(6,50)


CHARACTER (LEN=1) :: comment*80,    ! Comment (character string) from card type 4  &
    cadin_line*80  ! CADIN.ASC record producing error

LOGICAL :: eof_rchd

DATA maxstage/ 20 /, maxcard/ 500 /



nstg = 0    ! Initialize the stage counter.

!---  Rewind the input file and read the title.
REWIND ( id_cadin )

READ( id_cadin,'(A)',END=120) title(1:72)
120 CONTINUE


icrd = 0    ! Initialize the card counter.



140 CONTINUE

!     Read the next input record.

icrd = icrd + 1

IF( icrd > maxcard ) THEN
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Maximum number of initialization cards input.'
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP
END IF

!---  Set the endof file flag to true prior to the read.
eof_rchd = .true.

!---  Read the card data
READ(id_cadin,160,END=180,ERR=900) jtypes(icrd),  &
    ( als(j,icrd),j=1,3 ), locs(icrd), mods(icrd),  &
    va1s(icrd), va2s(icrd), mod2(icrd)
160 FORMAT( i2, 3A6, 2I5, 2E15.9, i2 )

!---  If the read was successful, then set the endoffile flag to
!---  false.  This assignment will be skipped if the end of file
!---  is reached, leaving the value of eof_reached at true.
eof_rchd = .false.


180 CONTINUE

IF( eof_rchd .AND. icrd < 2 ) THEN
  
!---      Check for an end of file after only 2 reads:  Not enough
!---      input data to perform an execution so exit.
  
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' End of file reached after only 2 input cards'
  WRITE(id_tabout,*) ' Not sufficient input for execution '
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
END IF


!     Card type 13 = stop trajectory.  If this is entered, then stop the
!     program; do what the user requested.

IF( jtypes(icrd) == 13 ) THEN
  
  WRITE(id_tabout,*) '  '
  WRITE(id_tabout,*) ' Card type 13 input.  '
  WRITE(id_tabout,*) ' RUN STOPPED '
  STOP ' '
  
  
ELSE IF( jtypes(icrd) == 16 ) THEN
  
  CALL rdi1_16card( istat, icrd, nstg  )
  
  IF( istat /= 0 ) THEN
    
!             Type 6 or 12 card encountered and variables already prepared.
!             Return to start trajectory calculations.
    
    RETURN
  ELSE
    
!             Type 10 card encountered.  End of stage data reached.  Go
!             read new data.
    
    GO TO 140
  END IF
  
ELSE IF( jtypes(icrd) == 12 ) THEN
  
!         Ncards is the number of cards in the storage arrays.
!         Set this value.
!         Type 12 card : don't include this card in the
!         storage deck.
  
  ncards = icrd - 1
  
!         Shift the data from the storing arrays into the
!         working arrays.
  
  CALL work
  
!         The end of the initialization cards has been reached.
!         Return and start the trajectory up to this point.
  
  RETURN
  
  
ELSE IF( jtypes(icrd) == 7 ) THEN
  
!          Card type = 7 : Vector initialization card .
!          Read the following special card types.
  
  CALL rdi1_7data( mods(icrd), nstg, va1s(icrd), va2s(icrd) )
  
  
ELSE IF( jtypes(icrd) == 8 ) THEN
  
!          Card type = 8 :  Atmospheric Data follows this card.
!          Read in this data.
  
  CALL rdi1_atmosphr( nwx, wxs )
  
  
ELSE IF( jtypes(icrd) == 9 ) THEN
  
!             Card type = 9 :  Header cards follow.  Read this data.
  
  nhol = locs(icrd)   ! Number of header cards following.
  
  READ(id_cadin,'(A80)',END=320) ( hols(k), k=1, nhol )
  320         CONTINUE
  
ELSE IF( jtypes(icrd) == 10 ) THEN
  
  CALL rdi1_10card( nstg, locs(icrd), mcris, mcrisc, vals )
  
  IF( nstg > maxstage ) THEN
    WRITE(id_tabout,*) ' '
    WRITE(id_tabout,*)' Maximum number of stages reached.'
    WRITE(id_tabout,*) ' RUN ABORTED '
    WRITE(id_tabout,*) ' '
    
    STOP ' '
  END IF
  
  
ELSE IF( jtypes(icrd) == 6 ) THEN
  
!             Card type 6: Ncards is the number of cards in the
!             storage arrays.  Set this value.
  
  ncards = icrd
  
!             Shift the data from the storing arrays into the
!             working arrays.
  
  CALL work
  
!             The end of the initialization cards has been reached.
!             Return and start the trajectory up to this point.
  
  RETURN
  
  
END IF


!     Go read the next card in the input.

GO TO 140


!  Error handler for reading CADIN.ASC file.  Executable CADIN.ASC records are
!  in a specific format.  This error handler will allow full length records for
!  record type 4 (comment cards).  If not card type 4, end program.

900 IF( jtypes(icrd) == 4 ) THEN
  BACKSPACE id_cadin
  READ( id_cadin, 910, END=180 ) jtypes(icrd), comment
  910     FORMAT( i2, a70 )
  GO TO 140
ELSE
  BACKSPACE id_cadin
  READ( id_cadin, '(A)') cadin_line
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Error reading CADIN.ASC'
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(8X,a,1X,a)
END IF

END SUBROUTINE rdi1_prim_traj

SUBROUTINE rdi1_7data( mode, nstage, evalue, v2 )

!-------------------------------------------------------------------------

!  Read the specialized type 7 cards.  Type 7 card  is the initialize
!  vector card.  This module reads the special cards that follow the
!  type 7 header card.   These cards contain the vector value in a
!  list-directed format.  A maximum of 20 variables is imposed and
!  a maximum of 10 cards may be entered.

!--Argument List Definitions--------------------------------------------

!  MODE   = (I) (+ or - ) and the number of elements in the array;
!  NSTAGE = (I) The current stage number.
!  EVALUE = (R) if mode .lt. 0, theis value is the value all elements
!               are to be set to.
!  V2     = (R) The returned value to be stored as the second real
!           variable of the type 7 card.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: mode
INTEGER, INTENT(IN OUT)                  :: nstage
REAL, INTENT(IN)                         :: evalue
REAL, INTENT(OUT)                        :: v2
COMMON /c7svd/  ic7s0, c7s0(10,20), ic7sn(20), c7sn(20,5,20)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


INTEGER, PARAMETER :: maxcs0 = 10
INTEGER, PARAMETER :: maxcsn= 5

CHARACTER (LEN=80) :: cadin_line


!---  Check to make sure that the data arrays are not full.
!     If room in arrays, set V2 now so that it is not forgotten.

IF( nstage == 0 ) THEN
  
!         Test for storing data in stage 0 array
  
  IF( ic7s0 >= maxcs0 ) THEN
    
!             Data arrays are full.  Give error messages
    
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) ' *** MAXIMUM NUMBER TYPE 7 CARDS EXCEEDED '
    WRITE(id_tabout,*) ' ***  IN STAGE 0 '
    WRITE(id_tabout,*)
    
    STOP ' '
    
  END IF
  
  ic7s0 = ic7s0 + 1
  
!         Save this information in the header card.
  
  v2 = ic7s0
  
ELSE
  
!         Test for storing data in the stage array
  
  IF( ic7sn( nstage ) >= maxcsn ) THEN
    
!             Data arrays are full.  Give error messages
    
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) ' *** MAXIMUM NUMBER TYPE 7 CARDS EXCEEDED '
    WRITE(id_tabout,*) ' ***  IN STAGE: ', nstage
    WRITE(id_tabout,*)
    
    STOP ' '
  END IF
  
  ic7sn( nstage ) = ic7sn( nstage ) + 1
  
!         Save this information in the header card.
  
  v2 = ic7sn( nstage )
  
END IF


!---  Determine which mode is being used to initialize the vector

IF( mode < 0 ) THEN
  
!         Mode 0 : Initialize all elements to the same value.
!         Save the information to the array.  Even though this
!         appears to be unnecessary, if this card is modified by
!         a group card, this allows the modification to be
!         properly performed.
  
  IF( nstage == 0 ) THEN
    
!             Stage 0 :
    
    c7s0( ic7s0, 1 ) = evalue
    
  ELSE
    
!             Stage N :
    
    c7sn( nstage, ic7sn( nstage ), 1 ) = evalue
    
  END IF
  
!         This mode has no following records.  All infomration
!         has been read and loaded into the proper arrays
!         so return from the module.
  
  
ELSE
  
!         Mode N : Initialize all elements to individual values.
!         Read the indiviidual values:
  
  nelements = ABS( mode )
  
  IF( nstage == 0 ) THEN
    
!             Stage 0 :
    
    READ(id_cadin,*,ERR=888,IOSTAT=IOSTAT) ( c7s0(ic7s0,i), i=1, nelements )
    
  ELSE
    
!             Stage 1 :
    
    READ(id_cadin,*,ERR=888,IOSTAT=IOSTAT)  &
        ( c7sn( nstage, ic7sn( nstage) , i ), i=1, nelements )
    
  END IF
END IF


GO TO 999


!---  Error message on the read statement

888 CONTINUE

WRITE( *, *)
WRITE( *, *) ' *** ERROR READING VALUES FROM TYPE 7 CARDS '
WRITE( *, *) ' *** FOR STAGE ', nstage

IF(IOSTAT /= 0) THEN
  BACKSPACE id_cadin
  READ(id_cadin,'(A)') cadin_line
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(6X,a,1X,a)
END IF


999 CONTINUE


RETURN
END SUBROUTINE rdi1_7data

SUBROUTINE rdi1_10card( nstage, ntest, intdata, chrdata, reldata )

!-------------------------------------------------------------------------

!  This module reads in the staging criteria that follows a type 10 card
!  from the input data file.  This data is stored into arrays and the
!  data is accessed later by other modules.
!  Card type = 10 : Read stage test(s), using C(N)

!  Format for card type 10 data:

!  Record #   Column number   Data

!   1*         1 -  2         "10"
!              25             Number of Tests (Integer 1 or 2)
!                * Card 1 has been read prior to this module being called.
!   2          1 -  6         Name of staging variable (Character)
!              7 - 11         C Element Location of Variable (Integer)
!             12 - 16         Integer staging flag (Integer 0 or 1)
!             18 - 23         Used if KODE = 0 (Character)
!             24 - 38         Variable Value (Real)
!             40 - 45         Units ? (Not used in Executive) (Character)
!             46 - 50         Staging flag KODE (Integer)
!   3**          Identical to record 2; contains the staging criteria for
!                the second staging test; mandatory when Ntest = 2



!--Argument List Definitions--------------------------------------------

!  NSTAGE         - (I) I/O.  The stage number that the stage cards
!                   apply to. This value is incremented within this module.
!  NTEST          - (I) Input.  The number of stage cards following the
!                   type 10 card.  NOTE:  at least 1 stage card must
!                   follow the type 10 card;  NTEST may be blank/zero
!                   for this case.
!  INTDATA(20,2,4)  - (I) Output. Contains the integer data input on the
!                   test criteria cards. ( Nstage, Ntest, Nth integer)
!  CHRDATA(20,2,2) - (C6) Output. Contains the character data input on
!                   the test criteria cards.
!                   (Nstage, Ntest, Nth Character data)
!  RELDATA(20,2)     - (R) Output. Contains the real data input on the
!                   test criteria cards.  (Nstage, Ntest)

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: nstage
INTEGER, INTENT(IN OUT)                  :: ntest
INTEGER, INTENT(OUT)                     :: intdata(20,2,4)
REAL, INTENT(IN OUT)                     :: chrdata
REAL, INTENT(IN OUT)                     :: reldata(20,2)

CHARACTER (LEN=80) :: cadin_line

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


!     Card type 10 : Read in the staging criteria cards:

!     Increment the stage number:

nstage = nstage + 1

!     Number of test cards following (1 or 2 ).  Will always be at
!     least 1 stage card following the type 10 card, but LOCS may be
!     blank/zero in this case.  Check for this.

IF( ntest /= 1  .AND.  ntest /= 2 ) ntest = 1

!     Read the stage cards:

DO ktest = 1, ntest
  READ(id_cadin,360,IOSTAT=IOSTAT,ERR=900,END=400) chrdata(nstage,ktest,1),  &
      ( intdata(nstage,ktest,l), l=1,2 ), chrdata(nstage,ktest,2),  &
      reldata(nstage,ktest), ( intdata(nstage,ktest,l), l=3,4 )
  360    FORMAT( a6, 2I5, 1X, a6, e15.9, 1X, i6, i5)
  
!---     This format statment was modified under t9201, Jan 1991.  The
!---     INTDATA(Nstage,Ktest,3) element was modified to be read as an
!---     integer.
!---     Reading character in the format, then changing to integer, placed a
!---     value in the variable when the input string contained blanks (due to
!---     hex value in variable?) This variable was assigned to the UNITS
!---     array in OINPT2, but UNITS was not used in the other executive
!---     modules or in the modules used for testing under this task.
!---     This is the original format statement:
!---       360    FORMAT( A6, 2I5, 1X, A6, E15.9, 1X, A6, I5)
  
  400    CONTINUE
  
  IF( intdata(nstage,ktest,1) < 1     .OR.  &
        intdata(nstage,ktest,1) > 3510  ) THEN
    
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) ' *** INVALID C LOCATION IN STAGE CRITERIA ***'
    WRITE(id_tabout,*)
    
    STOP ' '
  END IF
END DO

!     Error handler for errors reading the CADIN.ASC input file.
!     The errors found here result in format erros with type 10 stage test cards,
!     other than invalid C locations

900 IF(IOSTAT /= 0) THEN  ! Error occurred during CADIN read
  BACKSPACE id_cadin
  READ(id_cadin, '(A)') cadin_line
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Error reading CADIN.ASC'
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) 'RUN ABORTED'
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(8X,a,1X,a)
END IF

RETURN
END SUBROUTINE rdi1_10card

SUBROUTINE rdi1_16card( istat, icrd, nstg  )

!-------------------------------------------------------------------------

!     Card Type = 16 :  Continue Simulation.
!     This card signals that the following input cards are not to
!     be used until a stage requirement (from a type 10 card ) is
!     satisfied.  The cards following the type 16 card belong to the
!     next stage.   An end of stage is determined by a card of type
!     10 (the next stage), 6 (continue execution), 12 (next group).

!--Argument List Definitions--------------------------------------------

!  ISTAT - (I) Return status flag.  0 = continue reading from input.
!           1 = Type 6 card encountered; calculate trajectory.
!  ICRD  - (I) A card counter for the number of initialization cards
!                 read from the input file (35)
!  NSTG  - (I) The number of stages found in the initialization card
!                 deck.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: istat
INTEGER, INTENT(OUT)                     :: icrd
INTEGER, INTENT(OUT)                     :: nstg
COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /ipsav/   ncards, nhol, jtypes(500), locs(500), mods(500),  &
    va1s(500), va2s(500), mod2(500)

COMMON /ipsavc/  als(3,500), hols(5)
CHARACTER (LEN=80) :: hols chara ter*6 als

COMMON /ipsvsc/  mcris(20,2,4), vals(20,2)

COMMON /ipsvscc/ mcrisc(20,2,2)
CHARACTER (LEN=6) :: mcrisc

COMMON /ipsvst/  jtsts(20,60), locsts(20,60), modsts(20,60),  &
    va1sts(20,60), va2sts(20,60), mod2st(20,60), ncd(20)

COMMON /ipsvstc/ alsts(20,3,60)
CHARACTER (LEN=6) :: alsts

CHARACTER (LEN=80) :: cadin_line chara ter*80 comment

DATA maxstage/ 20 /, maxstcard / 60 /



istat = 0

!---  Initialize Counter for the number of cards in this stage.
nn = 1


100 CONTINUE

!---  Read the card data for the stages into a stage array.
!---  (ie JType for STageing Storage array. )
READ(id_cadin,160,END=220,ERR=900) jtsts(nstg,nn),  &
    ( alsts(nstg,l,nn), l=1,3), locsts(nstg,nn),  &
    modsts(nstg,nn), va1sts(nstg,nn), va2sts(nstg,nn), mod2st(nstg,nn)
160 FORMAT( i2, 3A6, 2I5, 2E15.9, i2 )
220 CONTINUE


IF( jtsts(nstg,nn) == 6  .OR.  jtsts(nstg,nn) == 10  &
      .OR.  jtsts(nstg,nn) == 12 ) THEN
  
!---      Card type 6, 12 or 10 found following a type 16 card.
!---      The card type 6,12,10 is not a part of the stage cards so
!---      correct the stage card counter and save this value into
!---      the proper array.
  ncd( nstg ) = nn - 1
  
  IF( jtsts(nstg,nn) /= 12 ) THEN
    
!---          Card type 6 or 10.  This card is not apart of the
!---          stage card set so load the data from this card
!---          into the appropriate arrays.
!---          (ie same arrays from previous loop)
    icrd = icrd + 1               ! Increment card counter.
    
!---          Transfer the data.
    jtypes(icrd) = jtsts(nstg,nn)
    
    DO k = 1, 3
      als(k,icrd) = alsts(nstg,k,nn)
    END DO
    
    locs(icrd) = locsts(nstg,nn)
    mods(icrd) = modsts(nstg,nn)
    va1s(icrd) = va1sts(nstg,nn)
    va2s(icrd) = va2sts(nstg,nn)
    mod2(icrd) = mod2st(nstg,nn)
    
    IF( jtypes(icrd) == 10 ) THEN
      
!---              Card type 10: read the data for this card type
      CALL rdi1_10card( nstg, locs(icrd), mcris, mcrisc, vals )
      
      IF(  nstg > maxstage ) THEN
        WRITE(id_tabout,*) ' '
        WRITE(id_tabout,*) ' Maximum number of stages reached. '
        WRITE(id_tabout,*) ' RUN ABORTED '
        WRITE(id_tabout,*) ' '
        
        STOP ' '
      END IF
      
!---              Continue the input process.
      istat = 0
      
      RETURN
      
      
    ELSE
      
!---              Card type 6: process like the card type 12.
      
!---              Ncards is the number of cards in the storage arrays.
!---              Set this value.C
      ncards = icrd
      
!---              Shift the data from the storing arrays into the
!---              working arrays.
      CALL work
      
!---              The end of the initialization cards has been reached.
!---              Return and start the trajectory up to this point.
      istat = 1
      
      RETURN
      
    END IF
    
  ELSE
    
!---          Card type 12
!---          Ncards is the number of cards in the storage arrays.
!---          Set this value.  Type 12 card : don't include this card
!---          in the storage deck.
    ncards = icrd - 1
    
!---          Shift the data from the storing arrays into the
!---          working arrays.
    CALL work
    
!---          The end of the initialization cards has been reached.
!---          Return and start the trajectory up to this point.
    istat = 2
    
    RETURN
    
  END IF
  
END IF

!---  Card type is other than 10,12,6 :
!---  Increment card counter for this stage.  Check for out of array
!---  bounds.
IF( jtsts(nstg,nn) == 7 ) THEN
  
!---      Card type 7 was entered.  Read the data from the file
!---      and load it into the proper arrays.
  CALL rdi1_7data( modsts(nstg,nn), nstg, va1sts(nstg,nn), va2sts(nstg,nn) )
  
END IF


nn = nn + 1

IF( nn > maxstcard ) THEN
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*)' Maximum number of stage input cards reached'
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
END IF

!     Go read the next record of data.

GO TO 100

!  Error handler for reading CADIN.ASC file.  Executable CADIN.ASC records are
!  in a specific format.  This error handler will allow full length records for
!  record type 4 (comment cards).  If not card type 4, end program.

900 IF( jtsts(nstg,nn) == 4 ) THEN
  BACKSPACE id_cadin
  READ( id_cadin, 910, END=220 ) jtsts(nstg,nn), comment
  910     FORMAT( i2, a70 )
  GO TO 100
ELSE
  BACKSPACE id_cadin
  READ( id_cadin, '(A)') cadin_line
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Error reading CADIN.ASC'
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(8X,a,1X,a)
END IF

END SUBROUTINE rdi1_16card

SUBROUTINE rdi1_atmosphr( nwx, wxs )

!-------------------------------------------------------------------------

!   This module reads in the atmospheric data that follows a type 8
!   card.

!--Argument List Definitions--------------------------------------------

!  NWX       - (I) The number of atmospheric data sets read into the
!              WXS array.
!  WXS(6,50) - (R) Output. Contains the atmospheric data as read from the
!              input cards.  WXS(I,J) :
!              I => 1 = Altitude, 2 = Wind Direction, 3 = Wind
!                 Velocity, 4 = Density, 5 = Temnperature, 6 = Pressure
!              Up to J=50 sets of atmospheric data may be entered.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: nwx
REAL, INTENT(OUT)                        :: wxs(6,50)


COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

CHARACTER (LEN=80) :: cadin_line

!     Read in the atmospheric data:

k = 0     ! Initialize the array counter.

240 CONTINUE
k = k + 1

!     Read the data from the input file

READ(id_cadin,*,END=260,IOSTAT=IOSTAT,ERR=900) ( wxs(m,k), m=1,6 )
260 CONTINUE

!     If the altitude is greater than 0.0, go read the next
!     record - End of weather is indicated by a negative altitude.

IF( wxs(1,k) >= 0.0 ) GO TO 240

!     End of atmospheric data reached.  Adjust data counter.

nwx = k - 1

!     Error handler for errors reading the CADIN.ASC input file
!     The errors found here result in format errors within the weather input records.
!     Type 4 (comment) records are allowed with the weather records only following
!     the correct format for comments (i.e. columns 1 and 2 must contain '04' followed
!     by the full length comment.  All other records between weather records are not
!     allowed.

900 IF(IOSTAT /= 0) THEN  ! Error encountered during weather data read
  BACKSPACE id_cadin
  READ(id_cadin,'(A)') cadin_line
  IF( cadin_line(1:2) == '04') THEN ! Comment record within weather data
    k=k-1 ! Reset the weather data counter
    GO TO 240
  ELSE    ! Error reading weather data
    WRITE(id_tabout,*) ' '
    WRITE(id_tabout,*) ' Error reading CADIN.ASC'
    WRITE(id_tabout,920) 'record: ', trim(cadin_line)
    WRITE(id_tabout,*) ' '
    WRITE(id_tabout,*) 'RUN ABORTED'
    WRITE(id_tabout,*) ' '
    
    STOP ' '
    920         FORMAT(8X,a,1X,a)
  END IF
END IF


RETURN
END SUBROUTINE rdi1_atmosphr

SUBROUTINE rdi2_group( flag13 )

!-------------------------------------------------------------------------

!  This module copies the primary trajectory data to the working
!  arrays; performs reads to the input file (unit 35) and acquires
!  the group data; then modifies the primary trajectory data or adds the
!  unique card to the set.

!--Argument List Definitions--------------------------------------------

!  FLAG13 - (L) Indicates if a card type 13 was found in the input.

!--Local Variable Definitions-------------------------------------------

!  NTEST - (I) Number of test cards following a type 10 card: Either 1
!          or 2.  There must be at least 1 stage card following the type
!          10 card but NTEST may be blank/zero for this case.

!-------------------------------------------------------------------------


LOGICAL, INTENT(IN OUT)                  :: flag13
COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al

COMMON /nad/     ibeen, ibegin, icard, isave





!     The initial read from the lead card deck has already been
!     performed until a type 6/12 card was reached.  After a type
!     6/12 card, the trajectory calculations start over.  Reload the
!     base trajectory into the working arrays and modify them with
!     the cards from the next group.

!---  Copy the saved primary trajectory cards into the working arrays.
CALL work


!---  Read the group cards.
CALL rdi2_rdcard( flag13 )


RETURN
END SUBROUTINE rdi2_group

SUBROUTINE rdi2_7gcread( ipos, mode, nstage, evalue, v2 )

!-------------------------------------------------------------------------

!  Read the specialized type 7 cards entered as a part of the group
!  cards.  Type 7 card is the initialize
!  vector card.  This module reads the special cards that follow the
!  type 7 header card.   These cards contain the vector value in a
!  list-directed format.  A maximum of 20 variables is imposed and
!  a maximum of 10 cards may be entered.

!--Argument List Definitions--------------------------------------------

!  IPOS   = (I) The position in the arrays where the data is to be
!           stored.
!  MODE   = (I) The number of elements in the array as either a + or -
!           value to select the initialization mode.  A - value initializes
!           all vector elements to the same value of V1;  A + value
!           initializes the vector elements to individual points.
!  NSTAGE = (I) The current stage number.
!  EVALUE = (R) For MODE < 0 : the value all elements are to be set to.
!  V2     = (R) The returned value to be stored as the second real
!           variable of the type 7 card.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: ipos
INTEGER, INTENT(IN)                      :: mode
INTEGER, INTENT(IN OUT)                  :: nstage
REAL, INTENT(IN)                         :: evalue
REAL, INTENT(OUT)                        :: v2
COMMON /c7wkd/   iwc7s0, wc7s0(10,20), iwc7sn(20), wc7sn(20,5,20)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

INTEGER, PARAMETER :: maxcs0 = 10
INTEGER, PARAMETER :: maxcsn= 5

CHARACTER (LEN=80) :: cadin_line


!      IF( NSTAGE .NE. 0 ) THEN

!---      Check to make sure that the data arrays are not full.
!         If room in arrays, set V2 now so that it is not forgotten.

!         Test for storing data in the stage array

!          IF( IC7SN( NSTAGE ) .GE. MAXCSN ) THEN

!             Data arrays are full.  Give error messages

!              WRITE(ID_TABOUT,*)
!              WRITE(ID_TABOUT,*) ' *** MAXIMUM NUMBER TYPE 7 CARDS EXCEEDED '
!              WRITE(ID_TABOUT,*) ' ***  IN STAGE: ', NSTAGE
!              WRITE(ID_TABOUT,*)

!              STOP ' '
!          ENDIF

!          IC7SN( NSTAGE ) = IC7SN( NSTAGE ) + 1

!         Save this information in the header card.
!      ENDIF


v2 = ipos


!---  Determine which mode is being used to initialize the vector


IF( mode < 0 ) THEN
  
!         Mode < 0 : Initialize all elements to the same value.
!         Save the information to the array.  Even though this
!         appears to be unnecessary, if this card is modified by
!         a group card, this allows the modification to be
!         properly performed.
  
  IF( nstage == 0 ) THEN
    
!             Stage 0 :
    
    wc7s0( ipos, 1 ) = evalue
    
  ELSE
    
!             Stage N :
    
    wc7sn( nstage, ipos, 1 ) = evalue
    
  END IF
  
!---      This mode has no following records.  All infomration
!---      has been read and loaded into the proper arrays
!---      so return from the module.
  
  
ELSE
  
!---      Mode > 0 : Initialize all elements to individual values.
!---      Read the indiviidual values:
  
  IF( nstage == 0 ) THEN
    
!             Stage 0 :
    
    READ(id_cadin,*,ERR=888,IOSTAT=IOSTAT) ( wc7s0( ipos, i ), i=1, mode )
    
  ELSE
    
!             Stage 1 :
    
    READ(id_cadin,*,ERR=888,IOSTAT=IOSTAT)  &
        ( wc7sn( nstage, ipos, i ), i=1, mode )
    
  END IF
END IF


GO TO 999


!---  Error message on the read statement

888 CONTINUE

WRITE( *, *)
WRITE( *, *) ' *** ERROR READING VALUES FROM TYPE 7 CARDS '
WRITE( *, *) ' *** FOR STAGE ', nstage
WRITE( *, *)

IF(IOSTAT /= 0) THEN
  BACKSPACE id_cadin
  READ(id_cadin,'(A)') cadin_line
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(6X,a,1X,a)
END IF


999 CONTINUE


RETURN
END SUBROUTINE rdi2_7gcread

SUBROUTINE rdi2_rdcard( flag13 )

!-------------------------------------------------------------------------

! This module reads the group cards from the lead card deck.  This read
! is performed after the primary trajectory has been calculated.  The
! primary trajectory cards are copies into the working arrays;  the group
! cards are read from the lead card deck and inserted/added/modify the
! primary trajectory cards accordingly.

!--Argument Definitions-------------------------------------------------

!  FLAG13 - (L) Flag that indicates whether a card type 13 was detected
!           or not.

!--Local Variable Definitions-------------------------------------------

!  JJ - (I) The card type of the new card being added.

!  The following data is read from the lead card deck and the
!  exact variable definitions are dependant on the card type:
!  A1 - (C6) The first character data read from the lead card deck.
!  A2 - (C6) The second character data read from the lead card deck.
!  A3 - (C6) The third character data read from the lead card deck.
!  KKARD - (I) Counter that counts the number of cards read for each
!          group.
!  LO - (I)  The first integer data read from the lead card deck.
!       Usually the location to be modified/defined by the input card.
!  MO - (I) The second integer data read from the lead card deck.
!  V1 - (R) The first real data read from the lead card deck.
!  V2 - (R) The second read data read from the lead card deck.
!  M1 - (I) The fourth integer data read form the lead card deck.
!  COMMENT - Type 4 card comment record
!  CADIN_LINE - Error record within ID_CADIN

!-----------------------------------------------------------------------


LOGICAL, INTENT(OUT)                     :: flag13
COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

CHARACTER (LEN=6) :: a3
CHARACTER (LEN=6) :: a2 chara ter*6 a1


CHARACTER (LEN=80) :: cadin_line chara ter*80 comment

flag13 = .false.
kkard  = 0


100 CONTINUE

!---  Read a group card from the lead card deck.  (JJ = card type.)
READ(id_cadin,160,END=3000,ERR=900) jj, a1, a2, a3 ,lo, mo, v1, v2, istg
160 FORMAT( i2, 3A6, 2I5, 2E15.9, i2 )

kkard = kkard + 1

IF( jj == 13 ) THEN
  
!         Card type 13 = end of inputs; finish the trajectory.
  
  flag13 = .true.
  RETURN
  
ELSE IF( jj == 4 ) THEN
  
!         Card type 4 = comment card for input deck.  Ignore this
!         card type/data.  Go read another card.
  
  GO TO 100
  
ELSE IF( jj == 12 ) THEN
  
!         End of group signaled.
  
  IF( kkard < 2 ) THEN
    
!             No cards were entered between this type 12 card and the
!             previous type 6/12 card.  Don't return - Read the next
!             group of cards.
    
    kkard  = 0
    GO TO 100
    
  ELSE
    
!             Go process this group of cards.
    
    RETURN
    
  END IF
  
END IF


!     Check the stage flag to see if this card mod/add applies to a
!     particular stage in the lead card set.

IF( istg < 1 ) THEN
  
!         This card is a mod/add to stage 0 - the cards prior to any
!         stages.  Search the stage for a matching card and update it
!         or if none found, add this card to this stage.
  
  CALL rdi2_st0search( jj, a1, a2, a3, lo, mo, v1, v2 )
  
ELSE
  
!         This card is a mod/add to a particular stage.  Search
!         the stage for a matching card and update it or if none found,
!         add this card to this stage.
  
  CALL rdi2_stnsearch( istg, jj, a1, a2, a3, lo, mo, v1, v2 )
  
END IF


!---  Go read the next lead card.
GO TO 100

!  Error handler for reading CADIN.ASC file.  Executable CADIN.ASC records are
!  in a specific format.  This error handler will allow full length records for
!  record type 4 (comment cards).  If not card type 4, end program.

900 IF( jj == 4 ) THEN
  BACKSPACE id_cadin
  READ( id_cadin, 910, END=3000 ) jj, comment
  910     FORMAT( i2, a70 )
  GO TO 100
ELSE
  BACKSPACE id_cadin
  READ( id_cadin, '(A)') cadin_line
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Error reading CADIN.ASC'
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(8X,a,1X,a)
END IF

3000 CONTINUE

!---  Read statment end label = End of input card deck.
STOP ' '

END SUBROUTINE rdi2_rdcard

SUBROUTINE rdi2_st0search( jj, a1, a2, a3, lo, mo, v1, v2 )

!-------------------------------------------------------------------------

!  This module searches the working card set for a card that matches
!  this current input card (card type and variable).  If no match is
!  found, an error message is displayed inthe output. If a match
!  is found, the new data is written over the old.  A special case is
!  considered when the card type is 9.  When this card type matches, the
!  variable is inappropriate for the type and ignored.

!--Argument Definitions-------------------------------------------------

!  JJ - (I) The card type of the new card being added.
!  The following data is read from the lead card deck and the
!  exact variable definitions are dependant on the card type:
!  A1 - (C6) The first character data read from the lead card deck.
!  A2 - (C6) The second character data read from the lead card deck.
!  A3 - (C6) The third character data read from the lead card deck.
!  LO - (I)  The first integer data read from the lead card deck.
!       Usually the location to be modified/defined by the input card.
!  MO - (I) The second integer data read from the lead card deck.
!  V1 - (R) The first real data read from the lead card deck.
!  V2 - (R) The second real data read from the lead card deck.
!  M1 - (I) The fourth integer data read from the lead card deck =
!       The stage number this card modifies/adds = stage 0

!--Local Variable Definitions-------------------------------------------

! JCARD  - (I) Counter for the number of cards in the working card deck.
! Saving arrays for swapping card locations:

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: jj
REAL, INTENT(IN)                         :: a1
REAL, INTENT(IN)                         :: a2
CHARACTER (LEN=6), INTENT(IN)            :: a3
INTEGER, INTENT(IN)                      :: lo
INTEGER, INTENT(IN)                      :: mo
REAL, INTENT(IN)                         :: v1
REAL, INTENT(IN)                         :: v2

CHARACTER (LEN=6) :: a2 chara ter*6 a1


COMMON /c7wkd/   iwc7s0, wc7s0(10,20), iwc7sn(20), wc7sn(20,5,20)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al



!     Initialize a variable to pass into a module

istage = 0

!     Initialize card counter:

jcard = 1


100 CONTINUE


IF( jj == jtype(jcard) .AND.  jj == 9 ) THEN
  
!---    Found a matching card type 9 : Read following header cards.
  READ(id_cadin,'(A80)',END=620) (holl(k),k=1,lo)
  620   CONTINUE
  
!---    Update the working set with this data.
  jtype(jcard) = jj
  al(1,jcard) = a1
  al(2,jcard) = a2
  al(3,jcard) = a3
  loca(jcard) = lo
  moe(jcard) = mo
  va1(jcard) = v1
  va2(jcard) = v2
  m2( jcard) = 0
  
  
ELSE IF( jj == jtype(jcard) .AND.  lo == loca(jcard) ) THEN
  
!---    The card is a match - it modifies the same variable in
!---    the same card type.  Update the working card set.
  
  
!---    If the card is a type 7 card, save the position of thedata.
  IF( jj == 7 ) ipos = va2( jcard )
  
!---    Load the new data over the old positions.
  jtype(jcard) = jj
  al(1,jcard) = a1
  al(2,jcard) = a2
  al(3,jcard) = a3
  loca(jcard) = lo
  moe(jcard) = mo
  va1(jcard) = v1
  va2(jcard) = v2
  m2( jcard) = 0
  
  
!---    If the card is a type 7, finish reading the data and apply
!---    the modifications to the working arrays.
  IF( jj == 7 ) CALL rdi2_7gcread( ipos, mo, istage, v1, va2(jcard) )
  
  
ELSE
  
!---    The card type does not match the JCARDth card in the working set.
!---    Increment JCARD.
  jcard = jcard + 1
  
  IF( jcard > ncard ) THEN
    
!---       Have checked all the cards in the working set and a
!---       match was not found.
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) ' Group card match NOT found in initial'
    WRITE(id_tabout,*) ' trajectory card set : '
    WRITE(id_tabout,650) jj, a1,a2,a3, lo,mo, v1,v2
    650      FORMAT( 1X, i2, 3A6, 2( i5, 1X ), 2( e15.9, 1X ) )
    WRITE(id_tabout,*)
    
  ELSE
    
!---      Go check the next card in the initialization card set.
    GO TO 100
    
  END IF
  
END IF

!---  Go read the next card from the input deck.

RETURN
END SUBROUTINE rdi2_st0search

SUBROUTINE rdi2_stnsearch( istg, jj, a1,a2, a3, lo, mo, v1, v2 )

!-------------------------------------------------------------------------

!  This module searches the working card deck for a card that matches
!  this current input card ( card type and variable).  If no match is
!  found, the card is added to the initialization card deck.  If a match
!  is found, the new data is written over the old.  NOTE: as can be
!  verified by the logic in RDIN_INIT, the stage card arrays will never
!  contain a type 10, 12 or 6 card;  therefore any additional cards
!  may simply be appended to the end of the deck for that stage.

!--Argument Definitions-------------------------------------------------

!  ISTG - (I) The stage number where the current input card is to be
!         place = The fourth integer data read from the lead card deck.
!  JJ   - (I) The card type of the new card being added.
!  The following data is read from the lead card deck and the
!  exact variable definitions are dependant on the card type:
!  A1   - (C6) The first character data read from the lead card deck.
!  A2   - (C6) The second character data read from the lead card deck.
!  A3   - (C6) The third character data read from the lead card deck.
!  LO   - (I)  The first integer data read from the lead card deck.
!         Usually the location to be modified/defined by the input card.
!  MO   - (I) The second integer data read from the lead card deck.
!  V1   - (R) The first real data read from the lead card deck.
!  V2   - (R) The second real data read from the lead card deck.

!--Local Variable Definitions-------------------------------------------

!  KNCARD - (I) The number of cards in the selected stage.
!  JCARD  - (I) Counter for counting through the stage cards.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: istg
INTEGER, INTENT(IN)                      :: jj
REAL, INTENT(IN)                         :: a1
REAL, INTENT(IN)                         :: a2
CHARACTER (LEN=6), INTENT(IN)            :: a3
INTEGER, INTENT(IN)                      :: lo
INTEGER, INTENT(IN)                      :: mo
REAL, INTENT(IN)                         :: v1
REAL, INTENT(IN)                         :: v2

CHARACTER (LEN=6) :: a2 chara ter*6 a1

COMMON /c7wkd/  iwc7s0, wc7s0(10,20), iwc7sn(20), wc7sn(20,5,20)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /wsetst/  ncdw(20), jtst(20,60), locst(20,60),  &
    modst(20,60), va1st(20,60), va2st(20,60), m2st(20,60)

COMMON /wsetstc/ alst(20,3,60)
CHARACTER (LEN=6) :: alst

INTEGER, PARAMETER :: maxcsn= 5


DATA maxstcard/ 60 /


kncard = ncdw( istg )

IF( kncard > 0 ) THEN
  
  jcard = 1
  
  100   CONTINUE
  
  IF(  jj == jtst(istg,jcard) .AND. lo == locst(istg,jcard)        ) THEN
    
!---      The card type and variable matches.  Update the card.
    
    
!---      If the card is a type 7 card, save the position of thedata.
    
    IF( jj == 7 ) ipos = va2st( istg, jcard )
    
    jtst(istg,jcard)   = jj
    locst(istg,jcard)  = lo
    modst(istg,jcard)  = mo
    m2st( istg,jcard)  = istg
    va1st(istg,jcard)  = v1
    va2st(istg,jcard)  = v2
    alst(istg,1,jcard) = a1
    alst(istg,2,jcard) = a2
    alst(istg,3,jcard) = a3
    
!---      If the card is a type 7, finish reading the data and apply
!---      the modifications to the working arrays.
    IF( jj == 7 ) CALL rdi2_7gcread( ipos,mo, istg, v1, va2st(istg,jcard))
    
!---      Go read next card from the lead card deck.
    RETURN
    
  END IF
  
!---    No match found - increment counter.
  jcard = jcard + 1
  
!---    If not reached the end of the cards - check the next card.
  IF( jcard <= kncard ) GO TO 100
  
END IF


!---  Either no cards in the stage, or no match in the cards.  Add the
!---  current input card to the stage cards.
IF( ncdw(istg) < maxstcard ) THEN
  
  IF( jj == 7 ) THEN
    
    IF( iwc7sn( istg )  < maxcsn ) THEN
      
!---        Add the data to the working arrays.
      ncdw(istg) = ncdw(istg) + 1
      
      jtst(istg,jcard)   = jj
      locst(istg,jcard)  = lo
      modst(istg,jcard)  = mo
      m2st( istg,jcard)  = istg
      va1st(istg,jcard)  = v1
      va2st(istg,jcard)  = v2
      alst(istg,1,jcard) = a1
      alst(istg,2,jcard) = a2
      alst(istg,3,jcard) = a3
      
      iwc7sn( istg ) = iwc7sn( istg ) + 1
      
      CALL rdi2_7gcread( iwc7sn(istg), mo, istg, v1, va2st(istg,jcard) )
      
    ELSE
      
      WRITE(id_tabout,*) ' '
      WRITE(id_tabout,*) ' Maximum number of initialization cards'
      WRITE(id_tabout,*) ' reached while reading group. '
      WRITE(id_tabout,*) ' RUN ABORTED '
      WRITE(id_tabout,*) ' '
      
      STOP ' '
    END IF
    
  ELSE
    
!---      Add this card to the end of the deck.
    ncdw(istg) = ncdw(istg) + 1
    
    jtst(istg,jcard)   = jj
    locst(istg,jcard)  = lo
    modst(istg,jcard)  = mo
    m2st( istg,jcard)  = istg
    va1st(istg,jcard)  = v1
    va2st(istg,jcard)  = v2
    alst(istg,1,jcard) = a1
    alst(istg,2,jcard) = a2
    alst(istg,3,jcard) = a3
  END IF
  
  
ELSE
  
!---    The maximum number of stage cards has been reached.
!---    Write an error message and stop.
  
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Maximum number of initialization cards '
  WRITE(id_tabout,*) ' reached while reading group. '
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
END IF


RETURN
END SUBROUTINE rdi2_stnsearch

SUBROUTINE rd_tape90

!-------------------------------------------------------------------------

!  This module loads data from tape 90 into the C array and sets the
!  appropriate flags.

!-------------------------------------------------------------------------

COMMON        c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/    jrun, mulrun, igroup

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /oindat/  j16, icd, i16

COMMON /prev/    tprev, cpprev, ppprev

COMMON /stage1/  istage, numstage


DIMENSION   ic(3510)

EQUIVALENCE (c(0001), ic(0001) )
EQUIVALENCE (c(2000), time  )


!     Restore the stage number and card number for when the save
!     occurred.

numstage = ibegin
icd = icard


j16 = 1
i16 = 1


OPEN( id_csave, FILE='CSAVE.ASC', STATUS='OLD' )

REWIND ( id_csave )
READ(id_csave, *)  c, ic

!--------------------------------------------------------------------

CLOSE( id_csave )

!---  End routine loaded inline.
tprev  = time


RETURN
END SUBROUTINE rd_tape90

SUBROUTINE op3_rtiwrite

!----------------------------------------------------------------------

!  This subroutine prints the necessary acronyms and data to the Real-
!  Time CADAC initialization data file.

!----------------------------------------------------------------------

DIMENSION plotdata(70), ic(3510)

COMMON c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opinit/  iplinit(70), intpinit(70), ninitvar
LOGICAL :: intpinit

COMMON /opinitc/ initlab
CHARACTER (LEN=1) :: initlab(70)*8

EQUIVALENCE (c(0001), ic(0001))

iplinit(1) = 2000

!---  Determine the data to print to the TRAJ.* files.
DO i = 1, ninitvar
  IF( intpinit(i) ) THEN
    plotdata(i) = ic( iplinit(i) )
  ELSE
    plotdata(i) = c( iplinit(i) )
  END IF
END DO

IF( initbin ) THEN
  WRITE(id_initbin)   ( plotdata(i), i=1,ninitvar )
  CLOSE( id_initbin )
END IF
IF( initasc ) THEN
  WRITE(id_initasc,*) ( plotdata(i), i=1,ninitvar )
  CLOSE( id_initasc )
END IF

RETURN
END SUBROUTINE op3_rtiwrite

SUBROUTINE sav_instream

!----------------------------------------------------------------------

!   Copy the input cards (unit 35) to the output file/display

!--Local Variable Definitions-------------------------------------------

!  HEADCARD - (C80) A character string used to read in the input title
!             and any header card data

!----------------------------------------------------------------------

PARAMETER ( maxtests = 2 )

DIMENSION wdata(6), values(20)
CHARACTER (LEN=80) :: cadin_line
CHARACTER (LEN=80) :: comment
CHARACTER (LEN=80) :: headcard
CHARACTER (LEN=6) :: a3
CHARACTER (LEN=6) :: a2 chara ter*6 a1

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!---  Rewind the input file.
REWIND (id_cadin)

!---  Start the input display at the top of page.
WRITE(id_tabout,50)
50  FORMAT('1')

!---  Read the title.
READ(id_cadin, '(A)' ) headcard
WRITE(id_tabout, * ) headcard

!---  Read the input cards:

!---  Loop: read the input card and write the card to output.  Continue
!---  until the end of file on input is reached.
70 CONTINUE

READ(id_cadin,90,END=110,ERR=900) i1, a1, a2, a3, i2 i3, r1, r2, i4
90 FORMAT( i2, 3A6, 2I5, 2E15.9, i2 )

WRITE(id_tabout, 100 ) i1, a1,a2,a3, i2,i3, r1,r2, i4
100 FORMAT( 1X, i4, 1X, 3A6, 1X, i6, 1X, i10, 1X, g15.5, 1X, g15.5, 1X, i3 )


IF( i1 == 7 ) THEN
  
!         Read the vector assignment cards : IF MODE > 0 then the
!         elements are assigned individual values which are input in
!         a free-field format on following cards.  IF MODE < 0,
!         no extra cards follow the type 7 card; this format is all
!         contained on this line.
  
  IF( i3 > 0  ) THEN
    
    IF( i3 < 21 ) THEN
      READ(id_cadin,*) ( values( num ), num = 1, i3 )
      WRITE(id_tabout, *) ( values( num ), num = 1, i3 )
    ELSE
      WRITE(id_tabout,*) ' *** ERROR - TOO MANY ELEMENTS IN TYPE 7 CARD *** '
    END IF
    
  END IF
  
ELSE IF( i1 == 8 ) THEN
  
!---      Read the weather deck cards which are in a different format.
!---      The weather data is list directed format having 6 values per
!---      record.  The first value is altitude.  A record with a
!---      negative altitude ( ie -1.0 or less ) signifies the end of
!---      data.
  
  
  104     CONTINUE
  
  READ(id_cadin,*) ( wdata(i), i=1,6 )
  
  IF( wdata(1) > -1.0 ) GO TO 104
  
  
ELSE IF( i1 == 9 ) THEN
  
!         Read the header cards which are in a different format.
  
  numcards = i2
  DO i = 1, numcards
    READ(id_cadin, '(A)', END=110) headcard
    WRITE(id_tabout,*) headcard
  END DO
  
ELSE IF( i1 == 10 ) THEN
  
!         Read the staging cards which are in a different format.
  
  ntests = i2
  IF( ntests < 1  .OR.  ntests > maxtests ) ntests = 1
  
  DO i = 1, ntests
    READ(id_cadin,106,END=110) a1, i1, i2, a2, r1, i3, i4
    106        FORMAT( a6, 2I5, 1X, a6, e15.9, 1X, i6, i5)
    
    WRITE(id_tabout,*) a1, i1, i2, a2, r1, i3, i4
    107        FORMAT( 1X, 2X, a6, 1X, i6, 1X, i6, 1X, a6, 1X, g15.5,  &
        1X, i7, 1X, i7 )
    
  END DO
  
END IF


GO TO 70

!  Error handler for reading CADIN.ASC file.  Executable CADIN.ASC records are
!  in a specific format.  This error handler will allow full length records for
!  record type 4 (comment cards).  If not card type 4, end program.

900 IF( i1 == 4 ) THEN
  BACKSPACE id_cadin
  READ( id_cadin, 910, END=110 ) i1, comment
  910     FORMAT( i2, a70 )
  
  WRITE(id_tabout,915) i1, comment
  915     FORMAT(i2,'(A)')
  GO TO 70
ELSE
  BACKSPACE id_cadin
  READ( id_cadin, '(A)') cadin_line
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' Error reading CADIN.ASC'
  WRITE(id_tabout,920) 'record: ', trim(cadin_line)
  WRITE(id_tabout,*) ' '
  WRITE(id_tabout,*) ' RUN ABORTED '
  WRITE(id_tabout,*) ' '
  
  STOP ' '
  920     FORMAT(8X,a,1X,a)
END IF

110 CONTINUE

!---  Force the following output to be at the top of page
WRITE(id_tabout,50)


RETURN
END SUBROUTINE sav_instream

SUBROUTINE setrandseq( inseed )

!----------------------------------------------------------------------

!     This module establishes the starting point of the pseudorandom
!     number generator.  In order to start a new sequence of random
!     numbers, a new seed value is sent to the SEED function.

!----------------------------------------------------------------------

CALL random_seed( inseed )                         ! MS statement.

!---  SVS statement:  In order to start a new sequence of random
!     numbers, a negative value is sent to the random function, RAN.
!     CALL RANDU( - ABS(INSEED), IDUM, RDUM )

RETURN
END SUBROUTINE setrandseq
!--------------------------------------------------------------------
!

FUNCTION signfunct( value )
!
!--------------------------------------------------------------------
!
!    This function generates a value equal to :
!               ABS( Value )      if  Rnum > 0.5
!      or  ( -1 * ABS( Value) )   if  Rnum < 0.5
!    where Rnum is a uniform random number between 0 and 1.0
!
!--------------------------------------------------------------------
!
! VALUE - (I) The absolute value to be returned by the function.  The
!         function will return this value with a rangom sign.
!
!--------------------------------------------------------------------
!
rvalue = ABS( value )
rnum = ranf()
!
IF( rnum <= 0.5 ) THEN
  signfunct = -1.0 * rvalue
ELSE
  signfunct = rvalue
END IF
!
RETURN
END FUNCTION signfunct

!-------------------------------------------------------------------------

FUNCTION sqr( a, per, tc )

!-------------------------------------------------------------------------



!---Argument Definitions------------------------------------------------

!  A   - (R) Input.
!  PER - (R) Input.
!  TC  - (R) Input.
!  SQR - (R) Output.

!-------------------------------------------------------------------------

x = a
tip = AMOD( tc, per )

IF( tip >= 0.5*per ) x = - x

sqr = x


RETURN
END FUNCTION sqr

!-------------------------------------------------------------------------







% Matlab useful??

SUBROUTINE stge2

!-------------------------------------------------------------------------


!-------------------------------------------------------------------------

COMMON      c(3510)

EQUIVALENCE (c(2011), kstep )
EQUIVALENCE (c(2020), lconv )


lconv = 0
kstep = 1

RETURN
END SUBROUTINE stge2

SUBROUTINE stge3( nsub )

!-------------------------------------------------------------------------

!  This module calls the G4 module and, if the trajectories have not
!  reached PCA or impact, check to see if a staging criteria has been
!  met.

!  Modifications:
!    *  Modifications made under T9108 affecting the sweep variables
!       and methodology.
!    *  Added Argument parameter to suppress extra staging message.
!    *  Some cleanup and structuring performed under T9108

!--Argument List Definitions--------------------------------------------

! NSUB - (I) Flag:  1 = STGE3 call from EXEC;  2= STGE3 called
!            from SUBL3.  This is a flag that was added under T9108
!            to distinguish which module called STGE3.  The EXEC
!            module calls the stage after reading input;  SUBL3 calls
!            the stage after each module is called to determine if it
!            is time to stage.  This can lead to the STGE module being
!            called twice for the same stage criteria if the criteria
!            is satisfied directly after an input or previous stage.
!            At this time it is undetermined if the double call is
!            necessary.  This flag is used to prevent output messages
!            from being printed until the SUBL3 module calls STGE3

!--Local Variable Definitions-------------------------------------------

!  STG_MET - (L) Flag that is true when a stage criteria has been met;
!            otherwise, the flag value is false.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: nsub
COMMON          c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /opplot/ ipladd(70), intplot(70)
LOGICAL :: intplot

COMMON /prev/   tprev, cpprev, ppprev

COMMON /stage/  loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest

COMMON /stage1/ istage, numstage


DIMENSION  ic(3510)

EQUIVALENCE (c(0001), ic(0001) )
EQUIVALENCE (c(1772), trcond   )
EQUIVALENCE (c(1800), isweep   )
EQUIVALENCE (c(1801), critno   )
EQUIVALENCE (c(1802), critval  )
EQUIVALENCE (c(1805), critmax  )
EQUIVALENCE (c(1811), anglno   )
EQUIVALENCE (c(1821), rangno   )
EQUIVALENCE (c(2000), time     )
EQUIVALENCE (c(2001), tstage   )
EQUIVALENCE (c(2003), pcnt     )
EQUIVALENCE (c(2011), kstep    )
EQUIVALENCE (c(2014), itcnt    )
EQUIVALENCE (c(2020), lconv    )
EQUIVALENCE (c(2280), nv       )
EQUIVALENCE (c(2866), icoor    )

DIMENSION pdata(70)
LOGICAL :: stg_met


!---  Call the G4 module to test for the end of a trajectory either by
!     impact or PCA

CALL g4


IF( lconv >= 2 ) THEN
  
!         G4 has detected the  Point of Closest Approach or impact
!         with the ground.  Stop the trajectory
  
!         Set the print time counter to (?) force last time printout.
  
  pcnt  = 0.0
  
!         Reset the integration flag = initialization mode.
  
  icoor = -1
  
!         Set the flag to control flow of execution in module EXEC
  
  kstep = 2
  
!         Call the auxillary modules one more time.
  
  CALL auxsub
  
!         Call the output module
  
  stg_met = .false.            ! Not called at a stage.
  CALL oupt3( stg_met )        ! Output the data to scroll/plot
  
!         If the critical value is less than the critical variable
!         but no terminate code is given, then the trajectory has been
!         stopped and not reached the correct end?  Prevent bad data
!         from being written to the sweep files.  The test for sweep is
!         greater than the critical value.  Assumption: sweep runs must
!         terminate with a termination code to be valid?
  
  icritno = critno          !really not needed BC
  critvar = c( icritno )    !really not needed BC
  
!--------------------------------------------------------------------------------
  
!          This is the old (XR94) if statement to determine if the trajectory
!          has reached the correct end.  This if statement is being replaced
!          to be based on LCONV instead of the value of the critical variable
  
!          IF( CRITVAR .LT. CRITVAL  .AND. TRCOND.LT. 0.9 ) THEN    !RETURN
  
!--------------------------------------------------------------------------------
  
  IF( lconv > 2 ) THEN
    
!---          Trajectory termination has occurred and has not reached the
!---          correct end (i.e. trajectory end outside terminal sphere)
!---          set critical variable to critmax and write this data to the
!---          sweep files           [added for XR97 - SWEEP5 Methodology]
    c( icritno ) = critmax
    
  END IF
  
!---      Check for changes in the minimum/maximum plot variable data.
  CALL ld_minmax
  
!---      If this is a sweep case, write the final conditions to the
!---      tape 10.
  IF( xsweep ) THEN
    
!---          Write the test criteria to the file.  Only do this for
!---          sweep option #4 and #5.  Other sweep options do not check the
!---          criteria data.
    IF( isweep > 3 ) WRITE(id_impact10,*)  &
        c(INT(critno)), c(INT(rangno)), c(INT(anglno))
    
!---          Store the plot data corresponding to the trajectory.
!---          Load the current value of the plot variable
    DO i = 1, nv
      IF( intplot(i) ) THEN
        pdata(i) = ic( ipladd(i) )
      ELSE
        pdata(i) = c( ipladd(i) )
      END IF
    END DO
    
    WRITE(id_impact7,*) ( pdata(i), i=1, nv )
    
  END IF
  
  
ELSE
  
!        Not the end of the trajectory.  Check to see if a staging
!        criteria has been met.
  
  CALL stg_eval( stg_met, ncriteria )
  
  IF( stg_met ) THEN
    
!            A staging criteria was met.  If printing is turned on,
!            print a message.
    
    IF( stgmsgout ) THEN
      
!---             The output message is turned on and this module was
!---             called from SUBL3
      l = loc( ncriteria )               ! C staging variable
      
      WRITE(id_tabout,500) numstage, ncriteria, l, c(2000)
      500            FORMAT( 1X, 'Stage ', i3, ' criteria # ', i2,  &
          ' satisfied.  Stage variable #: ', i6, ' Time: ', g12.5  )
    END IF
    
!---         Call the module to print the stageing data if the stage
!---         module is called from the SUBL3 module.  Prevent duplicating
!---         output for the same stage criteria.
    IF( nsub > 1 ) CALL oupt3( stg_met )
    
!---         Reset the print flag.
    itcnt  = 1
    tstage = 0.0
    tprev  = time
    
!---         Set the flag that controls execution in module EXEC
    IF( istage == 16 ) THEN
      
!---             Process next stage input.
      kstep = 3
    ELSE
      
!                Staging has occured and the end of trjaectory has been
!                signaled by a type 6 card
      
      lconv = 5
      kstep = 2
    END IF
    
  END IF
  
END IF


RETURN
END SUBROUTINE stge3

SUBROUTINE stg_eval( stg_met, ncriteria )

!-------------------------------------------------------------------------

!  Evaluate the staging criteria to determine if a stage condition has
!  been met.

!--Argument Definitions-------------------------------------------------

!  STG_MET - (L) Flag that is true when a stage criteria has been met or
!            false if conditions do not meet the stage criteria.
!  NCRITERIA - (I) When STG_MET is true, the number of the staging criteria
!            that was satisfied;  Otherwise the data returned is not
!            valid.

!-------------------------------------------------------------------------


LOGICAL, INTENT(OUT)                     :: stg_met
INTEGER, INTENT(OUT)                     :: ncriteria


COMMON      c(3510)

COMMON /stage/  loc(2), incrs(2), val(2), units(2), kode(2),  &
    test(2), loct(2), ntest


stg_met = .false.
ncriteria = 0


!---  Test to see if there are any tests defined.

IF( ntest < 1 ) RETURN


!---  Tests are defined.
!     Check to see if any of the criteria tests are satisfied.


DO i = 1, ntest
  
  l = loc(i)  ! C element location of staging variable
  
  IF( kode(i) <= 0 ) THEN
    
!            Compare the staging variable to the value pre-computed
!            and stored in the TEST array
    
    testval = test(i)
  ELSE
    
!            Compare the staging variable to the current value in
!            a C array location
    
    l1 = loct(i)       ! Location of the staging criteria.
    testval = c( l1 )
  END IF
  
  IF( c(l) < testval ) THEN
    
!            The stage variable is less than the stage criteria.
!            Only stage if the user has specified this relationship.
    
    IF( incrs(i) <= 0 ) THEN
      stg_met = .true.
      ncriteria = i
      RETURN
    END IF
    
  ELSE IF( c(l) > testval ) THEN
    
!            The stage variable is greater than the stage criteria.
!            Only stage if the user has specified this relationship.
    
    IF( incrs(i) > 0 ) THEN
      stg_met = .true.
      ncriteria = i
      RETURN
    END IF
    
  ELSE
    
!            The stage variable equals the stage criteria.  STAGE!
    
    stg_met = .true.
    ncriteria = i
    RETURN
    
  END IF
  
END DO


RETURN
END SUBROUTINE stg_eval

SUBROUTINE strt_plot( nplotvar )

!-------------------------------------------------------------------------

!  This module writes the starting plot file data (title and header
!  records )

!--Argument List Definitions-------------------------------------------

! NPLOTVAR - (I) Integer containing the number of variables input
!            selected for plotting on the HEADER file.

!--Local Variable Definition--------------------------------------------

! CJUNK8     (C8) - Spacers for printing the acronyms to TRAJ.*

!------------------------------------------------------------------------

!   29 September 1994:

!   The following variables were used to create a STAT.* file with 6
!   letter acronyms.  The file now creates 8 letter acronyms, but the
!   code was saved in case it is necessary to return to 6 letter acronyms.

! CJUNK      (C6) - Spacers for printing the acronyms to tape 44.  These
!            acronyms are only 6 characters.  Utility programs have not
!            been modified to handle the  8 char. acronyms.
! BLABLE(44) (C6) - The 6 char. acronyms for STAT.* data.  Utility
!            programs have not been modified to handle 8 chars to adapt
!            the acronyms to the 6 char length.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: nplotvar
COMMON  c(3510)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /hcom/    title
CHARACTER (LEN=100) :: title

COMMON /oppltc/  alable
CHARACTER (LEN=1) :: alable(70)*8

COMMON /opinit/  iplinit(70), intpinit(70), ninitvar
LOGICAL :: intpinit

COMMON /opinitc/ initlab
CHARACTER (LEN=1) :: initlab(70)*8

COMMON /optrack/  ipltrack(70), intptrack(70), ntrackvar
LOGICAL :: intptrack

COMMON /optrackc/ tracklab
CHARACTER (LEN=1) :: tracklab(70)*8


CHARACTER (LEN=1) :: cjunk8*8                ! , CJUNK*6, BLABLE(70)*6
DATA cjunk8 / '        '/         !  ,  CJUNK/'      '/


!---  Write headers and acronyms to TRAJ.BIN file if a binary trajectory
!---  file is being created.
IF( trajbin ) THEN
  WRITE(id_trajbin) title
  WRITE(id_trajbin) INT( c(1982) ), INT( c(1983) ), nplotvar
  WRITE(id_trajbin) ( alable(j), cjunk8, j=1, nplotvar )
END IF

!---  Write headers and acronyms to TRAJ.ASC file if an ascii trajectory
!---  file is being created.
IF( trajasc ) THEN
  WRITE(id_trajasc,100 ) '1', title
  100   FORMAT( a, a )
  WRITE(id_trajasc,110) INT( c(1982) ), INT( c(1983) ), nplotvar
  110   FORMAT( 1X, 3( i2, 1X ) )
  WRITE(id_trajasc,120) ( alable(j), cjunk8, j=1, nplotvar )
  120   FORMAT( 5( a8, a8 ) )
END IF


!---  Write the headers and acronyms to the STAT.* file.
!     Utility programs for STAT.* data have not been updated to
!     handle 8 char acronyms.  Adapt the 8 char acronyms to
!     maintain the 6 on tape 44.

!---  29 Sep 1994: STAT.* creates 8 letter acronyms, comment out
!---  code to create 6 letter acronyms.

!      DO J = 1, NPLOTVAR
!         BLABLE(J)(1:6) = ALABLE(J)(1:6)
!      END DO

!---  Write headers and acronyms to STAT.BIN file if a binary statistics
!---  file is being created.
IF( statbin ) THEN
  WRITE(id_statbin) title
  WRITE(id_statbin) INT( c(1982) ), INT( c(1983) ), nplotvar
  WRITE(id_statbin) ( alable(j), cjunk8, j=1, nplotvar )
END IF

!---  Write headers and acronyms to STAT.ASC file if an ascii statistics
!---  file is being created.
IF( statasc ) THEN
  WRITE(id_statasc,100 ) '1', title
  WRITE(id_statasc,110) INT( c(1982) ), INT( c(1983) ), nplotvar
  WRITE(id_statasc,120) ( alable(j), cjunk8, j=1, nplotvar )
END IF

!---  Write data to the RT CADAC files -------------------------------------
!---  Write headers and acronyms to INIT.BIN file if a binary initialization
!---  file is being created.
IF( initbin ) THEN
  WRITE(id_initbin) title
  WRITE(id_initbin) INT( c(1982) ), INT( c(1983) ), ninitvar
  WRITE(id_initbin) ( initlab(j), cjunk8, j=1, ninitvar )
END IF

!---  Write headers and acronyms to INIT.ASC file if an ascii initialization
!---  file is being created.
IF( initasc ) THEN
  WRITE(id_initasc,100 ) '1', title
  WRITE(id_initasc,110) INT( c(1982) ), INT( c(1983) ), ninitvar
  WRITE(id_initasc,120) ( initlab(j), cjunk8, j=1, ninitvar )
END IF

!---  Write headers and acronyms to TRACK.BIN file if a binary track
!---  data file is being created.
IF( trackbin ) THEN
  WRITE(id_trackbin) title
  WRITE(id_trackbin) INT( c(1982) ), INT( c(1983) ), ntrackvar
  WRITE(id_trackbin) ( tracklab(j), cjunk8, j=1, ntrackvar )
END IF

!---  Write headers and acronyms to TRACK.ASC file if an ascii track
!---  data file is being created.
IF( trackasc ) THEN
  WRITE(id_trackasc,100 ) '1', title
  WRITE(id_trackasc,110) INT( c(1982) ), INT( c(1983) ), ntrackvar
  WRITE(id_trackasc,120) ( tracklab(j), cjunk8, j=1, ntrackvar )
END IF


!---  At Dr.Zipfel's request the code to create a tape45 was commented
!---  out.  (29 Sep 1994)
!      WRITE(45,'(A)' )  '1' // TITLE
!      WRITE(45,*)  INT( C(1982) ), INT( C(1983) ), NPLOTVAR
!      WRITE(45, 100 )  (  ALABLE(J), CJUNK8, J=1, NPLOTVAR )
!  100 FORMAT( 1X, 5( A, A ) )


RETURN
END SUBROUTINE strt_plot

SUBROUTINE subl1

!-------------------------------------------------------------------------

!     This module controls the execution of the user-selected
!     modules.  The module numbers are entered on Type ___ cards.
!     Up to 99 cards may be entered.  Module numbers must be between
!     1 and 9 inclusive with the following definitions:
!         Module #    Module Name

!     NOTE:  NO modules are called by execution by this module.

!-------------------------------------------------------------------------

COMMON      c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

DIMENSION              subno(99)

EQUIVALENCE (c(2461), nosub )
EQUIVALENCE (c(2462), subno(1) )

!     NOSUB  = The number of subroutines to execute.
!     SUBNO(1) = The associated subroutine numbers to be executed


DO  i = 1, nosub
  
!        Get the module number to execute.
  
  j = subno(i)
  
!        Go execute the module.
  
  SELECT CASE ( j )
    CASE (    1)
      GO TO  1
    CASE (    2)
      GO TO  2
    CASE (    3)
      GO TO  3
    CASE (    4)
      GO TO  4
    CASE (    5)
      GO TO  5
    CASE (    6)
      GO TO  6
    CASE (    7)
      GO TO  7
    CASE (    8)
      GO TO  8
    CASE (    9)
      GO TO  9
  END SELECT
  WRITE(id_tabout,*) '  GOTOER IN SUBL1, J = ',j
  
  
  2    CONTINUE
  CYCLE
  
  3    CONTINUE
  CYCLE
  
  4    CONTINUE
  CYCLE
  
  5    CONTINUE
  CYCLE
  
  6    CONTINUE
  CYCLE
  
  7    CONTINUE
  CYCLE
  
  8    CONTINUE
  CYCLE
  
  9    CONTINUE
  
  
END DO



RETURN
END SUBROUTINE subl1

!-------------------------------------------------------------------------

SUBROUTINE subl2

!-------------------------------------------------------------------------

!     This module controls the execution of the initialization modules
!     for the modules selected with input card type 1.
!     Up to 99 cards may be entered.  Module numbers must be between
!     1 and 9 inclusive with the following definitions:
!         Module #    Module Name
!             3         OUPT2 - Initializatioin for OUPT3
!             4         STGE2 - Initialization for STGE3

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

DIMENSION              subno(99)

EQUIVALENCE (c(2461), nosub )
EQUIVALENCE (c(2462), subno(1) )

!     NOSUB    = The number of subroutines to execute.
!     SUBNO(1) = The associated subroutine numbers to be executed


DO  i = 1, nosub
  
!        Get the sub-module  number.
  
  j = subno(i)
  
!        Go execute the sub-module.
  
  SELECT CASE ( j )
    CASE (    1)
      GO TO  1
    CASE (    2)
      GO TO  2
    CASE (    3)
      GO TO  3
    CASE (    4)
      GO TO  4
    CASE (    5)
      GO TO  5
    CASE (    6)
      GO TO  6
    CASE (    7)
      GO TO  7
    CASE (    8)
      GO TO  8
    CASE (    9)
      GO TO  9
  END SELECT
  WRITE(id_tabout,*) '  GOTOER IN SUBL2, J = ',j
  
  
  2    CONTINUE
  CYCLE
  
  3    CONTINUE
  CALL oupt2
  CYCLE
  
  4    CONTINUE
  CALL stge2
  CYCLE
  
  5    CONTINUE
  CYCLE
  
  6    CONTINUE
  CYCLE
  
  7    CONTINUE
  CYCLE
  
  8    CONTINUE
  CYCLE
  
  9    CONTINUE
  
  
END DO



RETURN
END SUBROUTINE subl2

SUBROUTINE subl3

!-------------------------------------------------------------------------

!     This module controls the execution of the user-selected Cadac
!     modules.  The module numbers are entered on Type 1 cards.
!     Up to 99 cards may be entered.  Module numbers must be between
!     1 and 9 inclusive with the following definitions:
!         Module #    Module Name
!             3          OUPT3 - Controls output to scroll and plot
!             4          STGE3 -

!     NOTE: This module is similar to SUBL2 with the following
!           differences:
!           (1) Modules that are executed are different
!           (2) Variable C(1) is modified by this module.

!-------------------------------------------------------------------------

LOGICAL :: stgemet

COMMON      c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

DIMENSION              subno(99)

EQUIVALENCE (c(2461), nosub )
EQUIVALENCE (c(2462), subno(1) )

!     NOSUB  = The number of subroutines to execute.
!     SUBNO(1) = The associated subroutine numbers to be executed


c(1) = AMIN1( c(1), 0.1 )

DO  i = 1, nosub
  
!        Obtain the first sub-module number to be executed.
  
  j = subno(i)
  
!        Go execute the sub-module
  
  SELECT CASE ( j )
    CASE (    1)
      GO TO  1
    CASE (    2)
      GO TO  2
    CASE (    3)
      GO TO  3
    CASE (    4)
      GO TO  4
    CASE (    5)
      GO TO  5
    CASE (    6)
      GO TO  6
    CASE (    7)
      GO TO  7
    CASE (    8)
      GO TO  8
    CASE (    9)
      GO TO  9
  END SELECT
  WRITE(id_tabout,*) '  GOTOER IN SUBL3, J = ',j
  
  
  2    CONTINUE
  CYCLE
  
  3    CONTINUE
  
!        Call the module that prints data to scroll and to the plot
!        file.
  
  stgemet = .false.       ! Not called when a stage is met.
  CALL oupt3( stgemet )
  CYCLE
  
  4    CONTINUE
  
  icall = 2
  CALL stge3( icall )
  CYCLE
  
  5    CONTINUE
  CYCLE
  
  6    CONTINUE
  CYCLE
  
  7    CONTINUE
  CYCLE
  
  8    CONTINUE
  CYCLE
  
  9    CONTINUE
  
  
END DO


c(1) = 0.0


RETURN
END SUBROUTINE subl3

FUNCTION tri( amp, per, t )

!-------------------------------------------------------------------------


!--Argument Definitions-------------------------------------------------

!  AMP - (R) Input.
!  PER - (R) Input.
!  T   - (R) Input.
!  TRI - (R) Output.

!-------------------------------------------------------------------------


REAL, INTENT(IN)                         :: amp
REAL, INTENT(IN)                         :: per
REAL, INTENT(IN)                         :: t
DIMENSION b(4), s(4)

DATA b/ 0.0, 1.0, 0.0, -1.0 /,  s/ 4.0, -4.0, -4.0, 4.0 /


tip = AMOD( t, per )
a = 4 * tip
nqp = a/per + 1.0

tri = amp * b(nqp)  +  s(nqp) * AMOD( t/per, 0.25) * amp


RETURN
END FUNCTION tri

!-------------------------------------------------------------------------

FUNCTION unif( r, xm )

!-------------------------------------------------------------------------

!     This module returns a uniform random variable based on a given
!     mean and the width from the mean of the uniform function.

!--Argument Definitions-------------------------------------------------

!  R    - (R) Input. The distance on the axis from the mean to the upper
!             limit of the uniform function.
!  XM   - (R) Input. The mean of the uniform function.
!  UNIF - (R) Output. A uniform stochastic variable whose function is
!             centered about XM and the width of the function is 2 * R

!-------------------------------------------------------------------------

unif = xm  +  2.0 * r * ( ranf()-0.5 )


RETURN
END FUNCTION unif

SUBROUTINE work

!-------------------------------------------------------------------------

!     This module moves the initialization input card data from the
!  input storage arrays into the working space arrays.

!-------------------------------------------------------------------------

COMMON /c7svd/   ic7s0, c7s0(10,20), ic7sn(20), c7sn(20,5,20)

COMMON /c7wkd/  iwc7s0, wc7s0(10,20), iwc7sn(20), wc7sn(20,5,20)

COMMON /ipsav/   ncards, nhol, jtypes(500), locs(500), mods(500),  &
    va1s(500), va2s(500), mod2(500)

COMMON /ipsavc/  als(3,500), hols(5)
CHARACTER (LEN=80) :: hols chara ter*6 als

COMMON /ipsvsc/  mcris(20,2,4), vals(20,2)

COMMON /ipsvscc/ mcrisc(20,2,2)
CHARACTER (LEN=6) :: mcrisc

COMMON /ipsvst/  jtsts(20,60), locsts(20,60), modsts(20,60),  &
    va1sts(20,60), va2sts(20,60), mod2st(20,60), ncd(20)

COMMON /ipsvstc/ alsts(20,3,60)
CHARACTER (LEN=6) :: alsts

COMMON /ipsvwd/  nwx, wxs(6,50)

COMMON /winds/   walt(50), wdir(50), wvel(50), rhx(50),  &
    ctmp(50), wpres(50), nwindr, rhw

COMMON /wset/    ncard, jtype(500), loca(500), moe(500),  &
    va1(500), va2(500), m2(500)

COMMON /wsetc/   al(3,500), holl(5)
CHARACTER (LEN=80) :: holl chara ter*6 al

COMMON /wsetsc/  mcri(20,2,4), wval(20,2)

COMMON /wsetscc/ mcric(20,2,2)
CHARACTER (LEN=6) :: mcric

COMMON /wsetst/  ncdw(20), jtst(20,60), locst(20,60),  &
    modst(20,60), va1st(20,60), va2st(20,60), m2st(20,60)

COMMON /wsetstc/ alst(20,3,60)
CHARACTER (LEN=6) :: alst

COMMON /wsetwt/  wx(6,50)



iwc7s0 = 0
nstage = 0

!     Transfer the number of cards from the SAVED initialization deck
!     to the working variable.

ncard = ncards

!     Transfer the initialization data from the storage arrays into the
!     working arrays.

DO i = 1, ncard
  
!        Shift data into the working (?) arrays.
  
  jtype(i) = jtypes(i)
  loca(i)  = locs(i)
  moe(i)   = mods(i)
  
  DO j = 1,3
    al(j,i) = als(j,i)
  END DO
  
  va1(i) = va1s(i)
  va2(i) = va2s(i)
  m2(i)  = mod2(i)
  
!---     If card types 7, 8, 9 or 10 are encountered, transfer the data
!        accordingly.
  
  IF( jtypes(i) == 7 ) THEN
    
!            Card type 7 : Transfer vector data for stage 0
    
    iwc7s0 = iwc7s0 + 1
    
    DO ielem = 1, moe(i)
      wc7s0( iwc7s0, ielem ) = c7s0( iwc7s0, ielem )
    END DO
    
    
  ELSE IF( jtypes(i) == 8 ) THEN
    
!            Card type 8 : Load atmospheric data into working array.
    
    nwindr = nwx
    DO j = 1, nwindr
      DO m = 1, 6
        wx(m,j) = wxs(m,j)
      END DO
    END DO
    
    
  ELSE IF( jtypes(i) == 9 ) THEN
    
    numhol = loca(i)
    
    DO j = 1, numhol
      holl(j) = hols(j)
    END DO
    
    
  ELSE IF( jtypes(i) == 10 ) THEN
    
    nstage = nstage + 1
    ncdw(nstage) = ncd(nstage)
    
    ntest = loca(i)
    IF( ntest /= 1  .AND.  ntest /= 2 ) ntest = 1
    
    DO  k=1, ntest
      DO l = 1, 4
        mcri(nstage,k,l) = mcris(nstage,k,l)
      END DO
      
      mcric(nstage,k,1) = mcrisc(nstage,k,1)
      mcric(nstage,k,2) = mcrisc(nstage,k,2)
      wval(nstage,k) = vals(nstage,k)
    END DO
    
!            Transfer the data for the next stage:
    
    k = ncd(nstage)
    
    IF( k >= 1 )  THEN
      
      DO  nn=1,k
        
        jtst(nstage,nn)  = jtsts(nstage,nn)
        locst(nstage,nn) = locsts(nstage,nn)
        modst(nstage,nn) = modsts(nstage,nn)
        va1st(nstage,nn) = va1sts(nstage,nn)
        va2st(nstage,nn) = va2sts(nstage,nn)
        m2st( nstage,nn) = mod2st(nstage,nn)
        
        DO m = 1,3
          alst(nstage,m,nn) = alsts(nstage,m,nn)
        END DO
        
      END DO
      
!                Transfer any type 7 data for this stage.
      
      iwc7sn( nstage ) = ic7sn( nstage )
      
      DO istg = 1, 5
        DO ielem = 1, 20
          wc7sn( nstage, istg, ielem ) = c7sn( nstage, istg, ielem )
        END DO
      END DO
      
      
    END IF
    
  END IF
  
END DO


RETURN
END SUBROUTINE work

SUBROUTINE oinpt2

!-------------------------------------------------------------------------

!  This module is used at a severe error or when the trajectory has
!  impacted to the ground.  This module bypasses all of the cards in the
!  input deck until the type 6 card is found.   It also maintains the
!  value of ISAVE prior to the skipping cards.  If a type 90 card is
!  found in the cards being skipped, the ISAVE flag will be reset to the
!  original value since the data contained in the tape 90 file is likely
!  to be invalid.

!--Local Variable Definitions-------------------------------------------

!  IO_* = (I) The original values of the corresponding variables.  These
!          values are restored to the variables after the cards are
!          skipped.  ( IO_IBEEN, IO_IBEGIN, IO_ICARD, IO_ISAVE )

!-------------------------------------------------------------------------

COMMON /nad/    ibeen, ibegin, icard, isave


!     Save the value in ISAVE prior to skipping the cards.

io_ibeen  = ibeen
io_ibegin = ibegin
io_icard  = icard
io_isave  = isave

!     Skip all cards until the next type 16 or 6 card.

CALL oinpt1

!     If a type 90 card is encountered in the skip cards, the ISAVE
!     flag will be set.  Restore the value of ISAVE to the original value.

ibeen  = io_ibeen
ibegin = io_ibegin
icard  = io_icard
isave  = io_isave


RETURN
END SUBROUTINE oinpt2

SUBROUTINE c19_process( ir2, mode, vr, mint, iswth )

!-----------------------------------------------------------------------

!  This module reads the card data for the outer loop variable
!  definition and limits.

!--Argument List Definitions--------------------------------------------

!  The definitions of these variables is dependant on the card type.

!  IR2   - (I) Contains the SECOND integer value from the input card
!          that is currently being processed.  For this card type -
!          the variable is the element location in C of the outer
!          loop variable.  This variable should be the angle component
!          of a polar coordinate system for compatibility with SLAP
!  MODE  - (I) Contains an integer flag from the input card that is
!          currently being processed.  For this type - this variable
!          contains the delta/increment for the angle.
!  VR(2) - (R) Contains the real data from the input card that is
!          currently being processed. For this type - variable (1)
!          contains the minimum angle (2) contains the maximum angle.
!  MINT  - (I) The fourth integer on the card input;  the units of the
!          data:  0 = degrees - conversion necessary; 1 = radians - no
!          conversions necessary.

!-----------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(IN)                      :: mode
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(IN)                      :: mint
INTEGER, INTENT(OUT)                     :: iswth



COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1812), angmin )
EQUIVALENCE (c(1813), angmax )
EQUIVALENCE (c(1814), angdel )
EQUIVALENCE (c(1815), angunt )


anglno = ir2
angmin = vr(1)
angmax = vr(2)
angdel = mode
angunt = mint


IF( angmin > angmax ) THEN
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 19 - MIN GREATER THAN MAX ***'
  WRITE(id_tabout,*)
  iswth = 19
END IF

IF( angdel <= 0.0 ) THEN
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 19 - DELTA LESS OR EQUAL TO 0.0 ***'
  WRITE(id_tabout,*)
  iswth = 19
END IF

IF( anglno <= 0.0 ) THEN
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 19 - INVALID ANGLE NUMBER ***'
  WRITE(id_tabout,*)
  iswth = 19
END IF


RETURN
END SUBROUTINE c19_process

SUBROUTINE c20_process( ir2, mode, vr, iswth )

!-----------------------------------------------------------------------

!  This module reads the card data for the INNER loop variable
!  definition and limits plus some option flags.

!--Argument List Definitions--------------------------------------------

!  The definitions of these variables is dependant on the card type.

!  IR2   - (I) Contains the SECOND integer value from the input card
!          that is currently being processed.  For this card type -
!          the variable is the element location in C of the outer
!          loop variable.  This variable should be the range component
!          of a polar coordinate system for compatibility with SLAP
!  MODE  - (I) Contains an integer flag from the input card that is
!          currently being processed.  For this type - this variable
!          contains the delta/increment for the range.
!  VR(2) - (R) Contains the real data from the input card that is
!          currently being processed. For this type - variable (1)
!          contains the minimum range (2) contains the maximum range.

!-----------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(IN)                      :: mode
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(OUT)                     :: iswth



COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )
EQUIVALENCE (c(1824), randel )


rangno = ir2
ranmin = vr(1)
ranmax = vr(2)
randel = mode


IF( ranmin > ranmax ) THEN
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 20 - MIN GREATER THAN MAX ***'
  WRITE(id_tabout,*)
  iswth = 20
END IF

IF( randel <= 0.0 ) THEN
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 20 - DELTA LESS OR EQUAL TO 0.0 ***'
  WRITE(id_tabout,*)
  iswth = 20
END IF

IF( rangno <= 0.0 ) THEN
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 20 - INVALID RANGE NUMBER ***'
  WRITE(id_tabout,*)
  iswth = 20
END IF


RETURN
END SUBROUTINE c20_process

SUBROUTINE c21_process( ir2, mode, vr, mint, iswth )


!-----------------------------------------------------------------------

!  This module reads the card data for the sweep criteria definition.

!--Argument List Definitions--------------------------------------------

!  The definitions of these variables is dependant on the card type.

!  IR2   - (I) Contains the SECOND integer value from the input card
!          that is currently being processed.  For this card type -
!          the variable is the element location in C of the critical
!   number.
!  MODE  - (I) Contains an integer flag from the input card that is
!          currently being processed.  For this type - this variable
!          contains the current sweep methodology option.
!  VR(2) - (R) Contains the real data from the input card that is
!          currently being processed. For this type - variable (1)
!          contains the critical value and (2) contains the critical
!          when the trajectory terminates outside the terminal sphere
!   (this value is what is written to the IMPACT7 file
!   for LCONV = 4, added during XR97).
!  MINT  - (I) The fourth integer on the card input.  For this type -
!   the variable is the number of binary searches to be
!   performed.

!-----------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ir2
INTEGER, INTENT(IN)                      :: mode
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(IN)                      :: mint
INTEGER, INTENT(OUT)                     :: iswth



COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


EQUIVALENCE (c(1800), isweep  )
EQUIVALENCE (c(1801), critno  )
EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(1803), searno  )
EQUIVALENCE (c(1804), numr    )


isweep  = mode
critno  = ir2
critval = vr(1)
searno  = mint
numr    = vr(2)


IF( isweep > 3 ) THEN
  
!         Sweep option 4 or 5 selected.  Check other variables
!  for valid data.
  
  IF( critno <= 0.0   .OR.  critno > 3510.0  ) THEN
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) '*** CARD 21 ERROR: INVALID CRITERIA NUMBER ***'
    WRITE(id_tabout,*) '  CRITNO = ', critno
    WRITE(id_tabout,*)
    iswth = 21
  END IF
  
  IF( searno < 0.0  ) THEN
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) '*** CARD 21 ERROR: INVALID SEARCH NUMBER ***'
    WRITE(id_tabout,*) '  SEARNO = ', searno
    WRITE(id_tabout,*)
    iswth = 21
  END IF
  
  
ELSE IF( isweep >= 0  .AND.  isweep < 4 ) THEN
  
!         Options 0 - 3 selected.  Check the NUMR variable.
  
  IF( numr < 1.0  ) THEN
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) '*** CARD 21 ERROR: INVALID NUMBER OF RUNS ***'
    WRITE(id_tabout,*) '  NUMR = ', numr
    WRITE(id_tabout,*)
    iswth = 21
  END IF
  
  
ELSE
  
!         Invalid Sweep option entered.
  
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) '*** ERROR - CARD 21 - INVALID SWEEP MODE ***'
  WRITE(id_tabout,*) '    ISWEEP = ', isweep
  WRITE(id_tabout,*)
  iswth = 21
END IF


RETURN
END SUBROUTINE c21_process

SUBROUTINE c3_process( ir2, vr, mode, alpha3, iswth )

!-------------------------------------------------------------------------

!  Card type 3 : Variable initialization Cards.  These cards
!  allow values to be assigned to the C common variable
!  locations.

!    Card Format:
!      Column       Description
!        1-2         (I) "03" = Card type number
!        3-8         (C) Variable Name (Not used)
!        9-14        (C)
!       15-20        (C) Variable Style. (ALPHA3)
!       21-25        (I) Variable Number (IR2)
!       26-30        (I) Variable Initialization Flag (MODE)
!       31-45        (R)  (VR1)
!       46-60        (R)  (VR2)
!       61-62        (I) Stage number for multi run cases.

!--C Element List Definitions--------------------------------------------

!  C(0059) = OPNORO - Option flag: 1 = NON-rotating earth model
!            WEII3 = 0.0 ;
!            0 = Rotating earth model : WEII3 = 7.2921154E-05;

!  When the OPNORO flag is set by the type 3 card, perfrom the necessary
!  modifications to the WEII3 variable.  Equivalence this variable in
!  this module so that it can be detected by EQSORT and checked for
!  possible duplications of assignments with the modules.

!--Argument List Definitions--------------------------------------------

!  IR2    - (I) Input. The second integer input on the card = submodule
!               number.
!  VR(I)  - (R) Input. The two real values input on the card.
!  MODE   - (I) Input. The variable Initialization flag input on the
!               card.
!  ALPHA3 - (C6) Input. The third character variable input on the card.
!               Must equal:  'UNIF  ', 'GAUSS ', 'RAYLEI', 'EXPO  ',
!               'SIGN  ', or, 'EQUALS'
!  ISWTH  - (I) Output. Input Error flag.

!--Local Variable Definitions-------------------------------------------

!  ICARDTYPE - (I) The card type that is currently being processed.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: ir2
REAL, INTENT(IN)                         :: vr(2)
INTEGER, INTENT(IN)                      :: mode
CHARACTER (LEN=6), INTENT(IN)            :: alpha3
INTEGER, INTENT(OUT)                     :: iswth
COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/    jrun, mulrun, igroup

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON  c(3510)

DIMENSION ic(3510)

EQUIVALENCE (c(0001), ic(1)   )
EQUIVALENCE (c(0051), rearth  )
EQUIVALENCE (c(0054), agrav   )
EQUIVALENCE (c(0055), cftm    )
EQUIVALENCE (c(0057), amu     )
EQUIVALENCE (c(0058), weii3   )
EQUIVALENCE (c(0059), opnoro  )
EQUIVALENCE (c(0090), ranseed )





INTEGER :: seedflag

DATA seedflag/ 0 /



icardtype = 3


!---  Check for an invalid variable number (C location) to be
!     initialized.

IF( ir2 <= 0  .OR.  ir2 > 3510 ) THEN
  iswth = 103
  CALL oin1_emsg( icardtype )
  RETURN
END IF


!---  Process the card - assign the data to the variable as requested:

IF( mode > 0 ) THEN
  
!         'Integer' Variable - truncate any decimal and assign to
!         the input value.  See Section 3.3.2.
  
  ic( ir2 ) = vr(1)
  
ELSE
  
!         'Real' Variable - Determine if stochastic or deterministic.
!         See Section 3.3.1 and 3.3.3.
  
  IF( alpha3 /= '      ' ) THEN
    
!             Stochastic variable
    
    CALL c3_stoc_set( ir2, alpha3, vr )
    
  ELSE
    
!             Discrete REAL variable. Section 3.3.1
    
    c( ir2 ) = vr(1)
    
  END IF
  
END IF


!---  Check for special/flag variables that require action when they are
!     set:


IF( ir2 == 53   .AND.   vr(1) >= 0.001 ) THEN
  
!         Variable OPTMET : the Metric option flag value has been set
!         to select the metric option.  Convert earth constants from
!         feet to meters.
  
!         NOTE:  this is a one way conversion:  The default option for
!         the program is the English system.  When the flag is set
!         greater than 0, the program switches to the Metric system.
!         Notice that no provisions are made in the program to switch
!         back to the English system by setting the flag back to 0.
!         This was the way the program was designed prior to 91-08.
!         BUT if it is set, the user shouldn't be switching back and
!         forth.
  
  rearth = rearth * cftm
  agrav  = agrav * cftm
  amu    = amu * ( cftm**3. )
  
END IF


IF( ir2 == 59  .AND.  vr(1) < 0.5 ) THEN
  
!         Variable OPNORO :  = 0 = NON-Rotating earth model flag has
!         been set to 0 which selects the rotating earth model.  Set
!         the angular rotation of the earth (radians/sec).
  
  weii3 = 7.29211514E-5
  
ELSE IF( ir2 == 59  .AND.  vr(1) > 0.5 ) THEN
  
!         Variable OPNORO :  = 1 = NON-Rotating earth model flag has
!         been set to 1 which selects the NON rotating earth model.  Set
!         the angular rotation of the earth (radians/sec) to 0.0
  
  weii3 = 0.0
END IF



IF( ir2 == 90 ) THEN
  
!         Variable RANSEED:  Randon number function seed value entered.
  
!         Determine the initialization mode for the random function
!         generator:
!             VR(2) = 0  =>   Call ranset once at the beginning of the
!                             entire CADAC run and use  seed = VR(1)
!                             This is compatible with the original
!                             ranseed method added under T90?? and can
!                             be used to re-run a single trajectory
!                             of a multi-run group.
  
!             VR(2) = 1  =>   Call ranset when the card is processed,
!                             regardless of the number of times occurrs
!                             in the input and regardless of where the
!                             card occurrs in the input.
!                             Use  seed = VR(1) // "01"
  
!             VR(2) = 2  =>   Call ranset at the beginning of each
!                             trajectory ( and tape 90? ) and use
!                             seed = F( RANSEED, JRUN, IGROUP )
!                             This is so that individual trajectories
!                             from a series may be executed singly
  
!             VR(2) = 3  =>   Call ranset at the beginning of each
!                             trajectory ( and tape 90? ) and use
!                             seed = F( RANSEED, JRUN, 1 )
!                             to generate the same set of seeds for
!                             every group of trajectories.
  
  
!         NOTE:  It is the responsibility of the user to initialize this
!         seed value prior to the start of the first trajectory.  If the
!         card type 3 initializing the random number function is not placed
!         in the input stream until several stages into a trajectory and
!         random numbers have been utilized, the duplication of the exact
!         run is not guarenteed even with the same random number seed,
!         due to those stochastic variables set prior to random number
!         initialization.
  
  
  
  IF( vr(2) == 0 ) THEN
    
!             Call ranset once at the beginning of the entire CADAC
!             run and use  seed = VR(1) // "01"
    
    IF( seedflag /= 1 ) THEN
      
!                Even if monte carlo/multi-run cases are being executed,
!                the seed initialization will only be performed once.
      
      iseed = ranseed
      CALL setrandseq( iseed )    ! Start a new RV sequence.
      seedflag  = 1
      
      IF( ranvar ) THEN
        
!                    Only write the message if requrested by user.
!                    (Added by request of Dr. Zipfel - Dec 93 )
        
        WRITE(id_tabout,*)
        WRITE(id_tabout,*) ' RANDOM SEED INITIALIZATION: SEED=', iseed
        WRITE(id_tabout, *)
        
      END IF
      
    END IF
    
  ELSE IF( vr(2) == 1 ) THEN
    
!             The input card was encountered on the input deck.
!             Initialize the seed as requested using  seed = VR(1).
!             This was modified Aug 93 (see modif. note at top of code)
    
    inseed = ranseed
    iseed = ( inseed * 100 ) + 1
    
    CALL setrandseq( iseed )    ! Start a new RV sequence.
    
    
    IF( ranvar ) THEN
      
!                    Only write the message if requrested by user.
!                    (Added by request of Dr. Zipfel - Dec 93 )
      
      WRITE(id_tabout,*)
      WRITE(id_tabout,*) ' RANDOM SEED INITIALIZATION: SEED=', iseed
      WRITE(id_tabout,*) ' ENTER SEED = ', inseed, ' TO RE-RUN TRAJECTORY'
      WRITE(id_tabout,*)
    END IF
    
  ELSE
    
    norun = jrun
    
    IF( vr(2) /= 2 ) THEN
      nogroup = 1               ! VR(2) = 3
    ELSE
      nogroup = igroup          ! VR(2) = 2
    END IF
    
    CALL cad_seedcalc( iseedval, norun, nogroup )
    inseed = ( iseedval / 100 )
    iseed = iseedval
    
    CALL setrandseq( iseed )    ! Start a new RV sequence.
    
    IF( ranvar ) THEN
      
!                    Only write the message if requrested by user.
!                    (Added by request of Dr. Zipfel - Dec 93 )
      
      WRITE(id_tabout,*)
      WRITE(id_tabout,*) ' RANDOM SEED INITIALIZATION: SEED=', iseed
      WRITE(id_tabout,*) ' ENTER SEED = ', inseed, ' TO RE-RUN TRAJECTORY'
      WRITE(id_tabout,*)
      
    END IF
    
  END IF
  
END IF


RETURN
END SUBROUTINE c3_process

SUBROUTINE c3_stoc_set( ir2, alpha3, vr )

!-------------------------------------------------------------------------

!--Argument List Definitions-------------------------------------------

!  IR2    - (I) Input.  The C element number of the variable being set.
!  ALPHA3 - (C) Input.  The character string containing the
!               user-selected type for the stochastic variable.
!  VR(2)  - (R) Input. The real data values entered on the type 3 card.
!               The definition of these variables is dependant on the
!               type of stochastic variable entered in ALPHA3.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: ir2
CHARACTER (LEN=6), INTENT(IN)            :: alpha3
REAL, INTENT(IN)                         :: vr(2)
COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep


COMMON  c(3510)





!     Calculate the flags for detecting the selected variable type.
!     NOTE:  this may not be the most effective programming (ie in terms
!     of computer time) but does give clear coding (easy to read) and
!     is easy to mod to add more variable types.

iunif   = INDEX( alpha3, 'UNIF'   )
igauss  = INDEX( alpha3, 'GAUSS'  )
iexpo   = INDEX( alpha3, 'EXPO'   )
iraylei = INDEX( alpha3, 'RAYLEI' )
ISIGN   = INDEX( alpha3, 'SIGN'   )
iequals = INDEX( alpha3, 'EQUALS' )


IF( iunif > 0  ) THEN
  
!---    Uniform random variable selected.
  c( ir2 ) = unif( vr(2), vr(1) )
  
ELSE IF( igauss > 0  ) THEN
  
!---    Gaussian random variable selected.
  IF( vr(2) /= 0.0 ) c( ir2 ) = gauss( vr(2), vr(1) )
  
ELSE IF( iexpo > 0 ) THEN
  
!---    Exponential random variable selected.
  IF( vr(1) > 0.0 ) c( ir2 ) = expon( vr(1) )
  
ELSE IF( iraylei > 0 ) THEN
  
!---    Rayleigh random variable selected.
  IF( vr(1) > 0.0 ) c( ir2 ) = rayleigh( vr(1) )
  
ELSE IF( ISIGN > 0 ) THEN
  
!---    Sign function selected for variable determination.
  c( ir2 ) = signfunct( vr(1) )
  
ELSE IF( iequals > 0 ) THEN
  
!---    The Equal function selected for the variable
!---    initialization.  Set this variable equal the current value
!---    of a user selected C element.
  ielement = INT( vr(1) )
  c( ir2 ) = c( ielement )
  
ELSE
  
!---    An error has occurred:  The Alpha3 variable is non-blank
!---    but the text did not match the required function names.
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) ' ERROR ON TYPE 3 CARD - INVALID FUNCTION NAME:'
  WRITE(id_tabout,*) ' Variable num, Function Name: ', ir2, alpha3
  WRITE(id_tabout,*)
  
  c( ir2 ) = vr(1)
  
  IF( ranvar) WRITE(id_ranvar,*)  &
      ' ERROR ON TYPE 3 CARD - INVALID FUNCTION NAME:'
  
END IF


!---  Record to RANVAR.ASC the actual RANDOM values selected for the
!---  stochastic variables.
IF( ranvar ) WRITE( id_ranvar, *) ir2, ' ', alpha3, c(ir2)


RETURN
END SUBROUTINE c3_stoc_set

SUBROUTINE cad_seedcalc( iseedval, norun, nogroup )

!-------------------------------------------------------------------------

!   This module generates a random number seed based on the value in
!   RANSEED (C(0090)), NORUN and NOGROUP.
!   This module was modified Aug 93 due to a problem with reading a
!   number with more than 7 digits from the input deck.  The 32 bit VAX
!   only keeps 7 sig digits for a REAL variable ( this field is read real
!   then converted to integer).  Problems specifing a Seed with more than 7
!   digits.  BUT a seeds must differ by 10000 between consec. runs/groups to
!   produce a first value that is uniform.  Therefore try to allow the
!   user to enter the upper 7 digits and add '01' to the end (least sig) of
!   the number.

!--Argument List Definitions-------------------------------------------

!  ISEEDVAL - (I) Output.  The seed value calculated by this module.
!  NORUN    - (I) Input. The current trajectory run number.
!  NOGROUP  - (I) Input.  The current trajectory group number.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: iseedval
INTEGER, INTENT(IN)                      :: norun
INTEGER, INTENT(IN)                      :: nogroup
COMMON          c(3510)

EQUIVALENCE (c(0090), ranseed )


!---  Calculate the random number seed:
!     NOTE:  The random number seed is an integer and must be odd.
!            Consecutive (even then odd) values produce the same
!            random number sequence.

iranseed = INT( ranseed ) * 100

!     Insure the number is odd and apply the run and group numbers.

iaddvalue = ( norun * 1000000 ) + ( nogroup * 10000 ) + 1

!     Therefore the final result will be odd

iseedval = iranseed + iaddvalue


RETURN
END SUBROUTINE cad_seedcalc








SUBROUTINE exec

!-------------------------------------------------------------------------

!  This module opens the scratch files: IMPACT7.ASC and IMPACT10.ASC;
!  opens and reads the Head.ASC, loading the scroll variable arrays
!  and the plot variable arrays, then closes the file;  and provides the
!  control for the CADAC simulations under multi-run conditions.
!  Re-initializing the C variable from tape 90 is also performed in this
!  module.

!--Local Variable Definitions-------------------------------------------

! INITSUBS - (I) Flag: 0= Beginning of the trajectory - Execute the
!            initialization modules; 1= Middle of trajectory - Skip the
!            initialization modules.  Istage cannot be used for this
!            because it is modified by the input.
! NPLOTVAR - (I) The number of plot variables selected on the HEAD.ASC
!            file by the user.

!-------------------------------------------------------------------------

!---  Storage locations for exec are 50-99


COMMON           c(3510)

COMMON /ccom/    icf(25), icc(25), icl(25), ca(25),  &
    cl(25), ct0(25), nc, icl2(25)

COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /firsti/ finit
LOGICAL :: finit

COMMON /flag1/   initgauss
LOGICAL :: initgauss

COMMON /krun/    jrun, mulrun, igroup

COMMON /nad/     ibeen, ibegin, icard, isave

COMMON /oindat/  j16, icd, i16

COMMON /opflag/ intmsg, stgmsgout, inecho, xsweep
LOGICAL :: intmsg, stgmsgout, inecho, xsweep

COMMON /prev/    tprev, cpprev, ppprev

COMMON /stage1/  istage, numstage

COMMON /stagec/  name1(2), name2(2)
CHARACTER (LEN=6) :: name2 chara ter*6 name1

DIMENSION  der(101), v(101)


EQUIVALENCE (c(1801), critno  )
EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(2000), time    )
EQUIVALENCE (c(2006), itap90  )
EQUIVALENCE (c(2662), hmin    )
EQUIVALENCE (c(2663), hmax    )
EQUIVALENCE (c(2664), der(1)  )
EQUIVALENCE (c(2561), nip     )
EQUIVALENCE (c(2765), v(1)    )
EQUIVALENCE (c(2011), kstep   )
EQUIVALENCE (c(2285), nj      )
EQUIVALENCE (c(2280), nv      )
EQUIVALENCE (c(2001), tstage  )
EQUIVALENCE (c(2016), pgcnt   )
EQUIVALENCE (c(2020), lconv   )
EQUIVALENCE (c(2866), icoor   )


!      CHARACTER FILENAME*50
!      INTEGER GETENVQQ
LOGICAL :: flag13

!      DATA C/ 3510 * 0.0 /



!---  Open and process the Head.ASC file information.
CALL rdh1_headr( nplotvar )


!---  Open the output files and start the tabular output by writing the
!---  title, variable headings, etc.
CALL op_start( nplotvar )


!---  Read the input card and load the card data into the modules
CALL rdi1_init_cards



520 CONTINUE


!---  Perform a write to the RANVAR output file (if it is requested)
!     to assist in finding variables assignments used in multi-run
!     cases

IF( ranvar ) WRITE(id_ranvar,*) ' IGROUP = ', igroup, '  JRUN = ', jrun

!---  Very beginning of a trajectory calculation.
!     This section is the initialization of both Local and  EXEC common
!     variables.

initgauss = .false.

nc       = 0
numstage = 0    ! Stage counter.
j16      = 0    ! Flag: pull data from main trajectory arrays.
icd      = 0    ! Main trajectory card counter.
istage   = 0
initsubs = 0
tstage   = 0.0
tprev    = 0.0

!---  Initialize the C array to zeros:

CALL set_c_zero

!---  Setup a default critical value and variable for the non-sweep
!---  runs.   The input deck for sweep runs will reset these variables
!---  to the proper values.  The default variable for the non-sweep
!--   cases is DHJ = 1773.

critno = 1773
critval = 0.00001

!     Initialize the max and min plot variable arrays.

CALL ini1_pmin

!---  Re- Initialize the common location that contains the number of
!---  variables in the plot list since this value has been zero-ed out
!---  by the above loop.
nv = nplotvar

!     Initialize the flag which indicates the action of the EXEC after
!     each integration loop.

kstep   = 1

!     Initialize several earth and conversion variables.

CALL ini1_vars



IF( isave > 0 ) THEN
  
!         Data has been saved to a tape 90.  Read the data from the
!         tape.
  
  CALL rd_tape90
  
!         Type 90 cards must occur after a stage.  Set the flags
!         to inhibit re-entry into the initialization modules
!         when a simulation is being restored.
  
  istage   = 16
  initsubs = 1
  
!         Set the C variable that indicates when a trajectory is being
!         restarted from a type 90 save; This is set to 0 above (when
!         the C array is initialized)
  
  itap90 = 1
  
!         Call the D3I initialization module.  This facilitates the
!         sweep cases that "start" from a type 90 save.  This ITAP90
!         variable is used within D3I to inhibit initialization of
!         certain variables since this is NOT the beginning of the
!         original trajectory.  This call should not interfere with
!         Non-sweep cases since the D3I module should be in the "DUMMY"
!         modules because the D1I performs the initialization for
!         non-sweep cases.  Also, these modules should have IF tests
!         on MINIT to exit if an inappropriate case is being called.
  
!         Changed call to D3I to G1I.
!         Since this is in a section of the program that runs TAPE90
!         with the SWEEP option.  This setup of a TAPE90 and SWEEP has
!         not been fully checked out and will remain an undocumented
!         feature until it has been checked out.  [BC XR97]
  
!         Changed call to G1I with call SWEEPI since the SWEEP initialization
!         routines are now included in the executive routine CADX.FOR [BC 8 Sep 98]
  
  CALL sweepi
  
END IF



580 CONTINUE

!---  This section is where the input cards are processed.  The program
!     executes here at the beginning of each trajectory, and returns
!     here at the end of each stage to process the next set of stage cards.


IF( lconv <= 0  ) THEN
  
!         The trajectory has not reached termination as defined by G4
!         module.
  
!         Perform the input card processing.
  
  CALL oinpt1
  
  IF( hmin == 0.0 ) hmin = der(1)
  IF( hmax == 0.0 ) hmax = der(1)
  
  IF( initsubs == 0 ) THEN
    
!             This is the start of the trajectory computations.
!             At this point in the code, the variables have been
!             initialized and the stage 0 cards have been read
!             and processed.
    
!             IF( XSWEEP .AND. MULRUN .EQ. 0 ) THEN
    
!                 A Sweep case is being executed (Not with the multi-run
!                 mode : type 5 card)  Increment the run counter
!                 here (instead of in the type 21 card processing
!                 module {prior XR92} ) to keep the count of the number
!                 of executed trajectories correct.
    
!                  JRUN = JRUN + 1
!              ENDIF
    
    GO TO 800
    
  ELSE
    
!             In the middle of a trajectory either through a stage
!             or a type 90 card.  Insure some values of the Executive
!             common/control variables.
    
    lconv = 0
    kstep = 1
    pgcnt = 1
    
    intest = nv - 1
    noplot = MIN0( 70, MAX0( 0, intest) )
    IF( noplot > 0 )  ppcnt = time - 0.000001
    
!             Continue with integration cycle.
    
    GO TO 880
  END IF
  
ELSE
  
!         The end of the trajectory has occurred.
!         Read the input until an input card type 6 is found.
  
  DO WHILE ( istage /= 6 )
    CALL oinpt2
  END DO
  
  GO TO 1060
  
END IF




800 CONTINUE

!     This section performs module initialization.

!---  Execute the pre-initialization modules for the type 1 card
!     modules.  NOTE:  Currently no modules defined in this module

CALL subl1


!---  Call the initialization modules for the type 2 card modules.

icoor = -2

CALL auxi


!     Set the flag indicating that the initialization modules have been
!     executed for this trajectory.

initsubs = 1


!---  Execute the initialization modules for the type 1 cards:
!     Call the initialization modules for the modules specified on the
!     input type 1 cards ( OUPT2 and STGE2 )

CALL subl2


!---  Load the V and DER variables from the C array:
!     Calculate the number if integration variables defined.

n  = MAX0( 2, nip )

CALL ld_deriv( n )

880 CONTINUE

!     This section controls the execution of the modules and the
!     integration cycle.

!---  Execute the auxillary modules (type 2 card modules )

icoor = -1

!     Call the modules specified on the type 2 cards.

CALL auxsub

IF( finit ) THEN
  
!     Call the RT initialization routine if a RT INIT file is to be
!     created
  
  CALL op3_rtiwrite
  CALL op3_rtwrite
  finit = .false.
  
END IF

!     Check for stage conditions being met.
!     This call statement was removed so that a redundant call to the stage
!     test routine was not called.  The stage routine is called after each
!     integration cycle is complete.  This call was made immediately after
!     group cards were loaded or after a previous stage [BC 8 Sep 98]
!BC      ICALL = 1
!BC      CALL STGE3( ICALL )


IF( nip > 100 ) THEN
  
  WRITE(id_tabout,940)
  940     FORMAT( '0------ TOO MANY STATE VARIABLES. ',  &
      'RUN ABORTED. ------' )
!         Read the input until an input card type 6 is found.
  
  DO WHILE ( istage /= 6 )
    CALL oinpt2
  END DO
  
  GO TO 1060
END IF



960 CONTINUE


!---  Execute the integration modules.

n = MAX0( 2, nip )
n = MIN0( n, 100 )

nj = n - 1        ! Used in AMRK module

CALL amrk


!---  Shift the data produced by the integration arrays into the C arrays.

CALL ld_carray( n )


!---  Execute the card type 1 modules.

CALL subl3


!---  Check the status of the integration cycle:

IF( kstep == 1 ) THEN
  
!         No change in status - Continue the integration cycle.
  
  GO TO 960
  
ELSE IF( kstep == 2 ) THEN  !zzzz
  
!         End of trajectory detected - Read the input until an input
!         card type 6 is found (incase not already at a type 6 card)
  
  DO WHILE ( istage /= 6 )
    CALL oinpt2
  END DO
  
!---  Call STGE3 to write data to SWEEP files at end of total miss trajectory
  
  IF( lconv == 5 ) THEN
    icall = 1
    CALL stge3( icall )
  END IF
  
ELSE IF( kstep == 3 ) THEN
  
!         The current stage requirements have been met.
  
  GO TO 580
  
END IF




1060 CONTINUE

!---  This section controls execution when the end of the trajector has
!---  been detected.


!---  Reset control flags
kstep = 1
lconv = 0
tprev = 0.0

!---  Zero the integration array.
DO jv = 2, n
  v(jv) = 0.0
END DO


!---  Check for special execution cases:


IF( xsweep ) THEN
  
!---       A sweep case is being executed and a trajectory has
!---       completed.
  
!---       Write the final trajectory data to the TRAJ.* file: ie the
!---       -1.0 record and the max data record.
  IF( trajbin ) THEN
    iunit = id_trajbin
    CALL op3_pf11( iunit )
  END IF
  IF( trajasc ) THEN
    iunit = id_trajasc
    CALL op3_pf11( iunit )
  END IF
  
  
  IF( mulrun > 0   .AND.  jrun >= mulrun ) THEN
    
!---           Finished all trajectory runs in the current sweep
!---           position (angle and range setting).  Reset the run
!---           counter and increment the group counter.
    jrun   = 0
    igroup = igroup + 1
  END IF
  
!---       Copy the primary, stored trajectory into the working arrays
!---       and run the next trajectory sweep.   The card type 18 causes
!---       the adjustments in the trajectory.
  CALL work
  
!---       Restart for the next trajectory.  Branch to initialization.
  jrun = jrun + 1
  GO TO 520
  
END IF


!---  Write the final trajectory data to the trajectory file: ie the
!---  -1.0 record and the max data record.
IF( trajbin ) THEN
  iunit = id_trajbin
  CALL op3_pf11( iunit )
END IF
IF( trajasc ) THEN
  iunit = id_trajasc
  CALL op3_pf11( iunit )
END IF


IF( mulrun > 0 ) THEN
  
!---      Multi-run trajectory case:
!---      If the run counter is less than the maximum number of runs
!---      to be perform, then increment run counter and go perform another
!---      trajectory run.  Branch to the trajectory initialization.
  IF( jrun < mulrun ) THEN
    jrun = jrun + 1
    GO TO 520
  END IF
  
!---      Else - Finished all runs in the multi-run case.  Reset the run
!---      counter.  Reset the read from CSAVE.ASC file to indicate start
!---      of new group trajectory
  
  jrun   = 1
  isave = 0
  
END IF

!---  Trajector(y/ies) for this base card set completed.  Continue
!---  reading the file to determine if group cards exist, and if so, process
!---  these trajectories.

!---  Increment the group counter.
igroup = igroup + 1

!---  Copy the primary trajectory to the working arrays,
!---  read the lead card deck for the cards in the next group and
!---  modifies/add them to the primary trajectory accordingly.
CALL rdi2_group( flag13 )

!---  If a card type 13 has not been read (or abnormal end of file
!---  reached), then a type 12 card at the end of a group card set
!---  was detected.  Go compute this trajectory.
IF( .NOT. flag13  ) GO TO 520


!---  A type 13 card was encountered in the input stream.
!     End of simulation:  write the ending records to the trajectory file
!---  and statistics files. Then close the files.
!---  NOTE: Since converted from MS PowerStation 4.0 to Digital Visual FORTRAN
!           the ENDFILE statement was replaced with the CLOSE statement to
!           correctly disassociate the unit ID from the file without errors
!           for binary files. (The error was produced b/c the file was not opened
!           as a sequential file ?)   [BC 26 May 98]

IF( statbin ) THEN
  iunit = id_statbin
  CALL op3_pf11( iunit )
  CLOSE( id_statbin )
END IF
IF( statasc ) THEN
  iunit = id_statasc
  CALL op3_pf11( iunit )
  CLOSE( id_statasc )
END IF

!---  The end records have already been recorded to the trajectory file.
IF( trajbin )  CLOSE( id_trajbin )
IF( trajasc )  CLOSE( id_trajasc )
IF( trackbin ) CLOSE( id_trackbin )
IF( trackasc ) CLOSE( id_trackasc )

STOP
END SUBROUTINE exec




SUBROUTINE set_c_zero

!-------------------------------------------------------------------------

!  This module initializes all elements of the C array to zero.

!--Local Variable Definitions-------------------------------------------

!  I - (I) DO loop counting variable to increment through all of the C
!          array elements.

!-------------------------------------------------------------------------

COMMON  c(3510)


DO i = 1, 3510
  c(i) = 0.0
END DO


RETURN
END SUBROUTINE set_c_zero

SUBROUTINE swp_6print( irun )

!-------------------------------------------------------------------------

!  This module prints data to the tabular output file, unit 6.

!--Argument List Definition---------------------------------------------

!  IRUN - (I) The trajectory number of the inner loop.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN OUT)                  :: irun
COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1800), isweep )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )

! ISWEEP = Flag: 0 = no sweep; 1n : n = sweep option
! ANGLNO = The C element number for the outer variable.
! RANGNO = The C element number for the inner variable.


!---  Convert the inner loop variable to integer.
irangno = rangno

!---  Print the data to the tabular output file.
WRITE(id_tabout,1340) irun, c(INT(anglno)), c(INT(rangno)), isweep, irangno

1340 FORMAT( /1X, 'RUN # ', i3, ' OUTER= ', g12.5, 'INNER= ',  &
    g12.5, ' OPT #= ', i3, ' INNER VAR #= ', i5 )


RETURN
END SUBROUTINE swp_6print

SUBROUTINE swp_7data( ndata )

!-------------------------------------------------------------------------

!  This module transfers NDATA records of NV data from the unit 7
!  scratch file, to the tape 22 file.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ndata
DIMENSION pdata(70)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON c(3510)

!***  Input from other modules

EQUIVALENCE (c(2280), nv )


!---  NOTE:  The for007 file is assummed to already be open and written
!---  to.  The Swp_runinit opens the file and the STGE3 module writes to
!---  the file when the trajectory generates a miss distance/pca.
!---  Read and transfer the data written to the file.
REWIND ( id_impact7 )

DO i = 1, ndata
  READ(id_impact7,*,END=100)   ( pdata(j), j=1, nv )
  WRITE(id_impact,*) ( pdata(j), j=1, nv )
END DO


100 CONTINUE


!---  Close the file, then re-open the file in preparation of the next
!---  trajectory.  The file is closed (instead of rewound) so that if
!---  the trajectory is not normally terminated, the file will be empty
!---  and invalid data will not be transfered to unit ID_IMPACT.
CLOSE( id_impact7, STATUS = 'DELETE' )
!---      PRINT *, 'FILENAME:', FILENAME(1:LENSTR(FILENAME))
OPEN( UNIT=id_impact7,  FILE='IMPACT7.ASC',  STATUS='UNKNOWN' )


RETURN
END SUBROUTINE swp_7data

SUBROUTINE swp_7data45( ndata, ipos )

!-------------------------------------------------------------------------

!  This module transfers NDATA records of NV data from the unit 7
!  scratch file, to the tape 22 file.  Called only from SWEEP4 and
!  SWEEP5 Methodology.  Created under XR97.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ndata
INTEGER, INTENT(IN)                      :: ipos(100)
DIMENSION pdata(70)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON c(3510)

!***  Input from other modules

EQUIVALENCE (c(2280), nv )


!---  NOTE:  The for007 file is assummed to already be open and written
!---  to.  The Swp_runinit opens the file and the STGE3 module writes to
!---  the file when the trajectory generates a miss distance/pca.
!---  Read and transfer the data written to the file in ascending range order.
REWIND ( id_impact7 )

DO i = 1, ndata
  DO j = 1, ipos( i )
    READ(id_impact7,*,END=100)   ( pdata(k), k=1, nv )
  END DO
  WRITE(id_impact,*) ( pdata(k), k=1, nv )
  REWIND (id_impact7 )
END DO


100 CONTINUE


!---  Close the file, then re-open the file in preparation of the next
!---  trajectory.  The file is closed (instead of rewound) so that if
!---  the trajectory is not normally terminated, the file will be empty
!---  and invalid data will not be transfered to unit ID_IMPACT.
CLOSE( id_impact7, STATUS = 'DELETE' )
OPEN( UNIT=id_impact7,  FILE='IMPACT7.ASC',  STATUS='UNKNOWN' )


RETURN
END SUBROUTINE swp_7data45

SUBROUTINE swp_critcheck

!-------------------------------------------------------------------------

!  This module performs a check on the criteria maximum value, CRITMAX,
!  C(1805).  This module was added during task XR92.

!  At the beginning of each sweep trajectory, the C array is init. to
!  0.0.  Then the stage 0 cards are processed.  If the CRITMAX value is NOT
!  initialized by a type 3 card, the location contains a 0.0 value; else
!  the location will contain the value entered by the user.  This module
!  checks the CRITMAX variable and if it contains a value less than the
!  CRITVAL (minimum critical value), then the CRITMAX is initialized to be
!  equal to CRITVAL + 9.0E+05.

!-------------------------------------------------------------------------

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(1805), critmax )

! CRITVAL = The minimum critical value for the criteria test.
! CRITMAX = The maximum critical value for the criteria test.

LOGICAL :: printmsg   /.false./


IF( critmax <= critval ) THEN
  
!---    The maximum critical value is not a valid value.
!---    Modify the CRITMAX:
!       Default CRITMAX to 0.0 [bc 24 Spet 98]
!BC        CRITMAX = CRITVAL + 9.0E+05
  critmax = 0.0
  
  IF( printmsg ) THEN
    
!---      Print an error message if maximum critical value is being changed.
    WRITE(id_tabout,*) ' '
    WRITE(id_tabout,*) ' ***MAXIMUM CRITICAL VALUE BEING MODIFIED***'
    WRITE(id_tabout,*) '    CRITMAX = 0.0   '
    WRITE(id_tabout,*) ' '
    
    printmsg = .false.
    
  END IF
  
END IF


RETURN
END SUBROUTINE swp_critcheck

SUBROUTINE swp_datchk( ransave, goodat, critdat )

!-------------------------------------------------------------------------

!   This module reads the impact10 scratch file and checks the range data
!   against the current range data.  If the ranges match to within a
!   set tolerance, the GOODATa flag is set TRUE and the value of the
!   critical variable calculated for the range is returned.  If the
!   ranges do not match (traj was stopped by the program or the
!   trajectory was a 'miss'), then the gooddata flag is set FALSE.

!--Local Variable Definitions---------------------------------------------

!  KRIT  - (I) Pointer into the RDATA array to the criteria data.
!  NV10  - (I) The number of variables writted to the scratch file by
!          module STGE3.  The max number of variables in RDATA
!  RDATA(3) - (R) Array of data generated at the end of the sweep runs.

!-------------------------------------------------------------------------


REAL, INTENT(IN)                         :: ransave
LOGICAL, INTENT(OUT)                     :: goodat
REAL, INTENT(OUT)                        :: critdat


DIMENSION rdata(3)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

DATA krit/ 1 /, kvar1/ 2 /, nv10/ 3 /


!---  Rewind the scratch and read the results of the latest trajectory.

REWIND (id_impact10)

READ(id_impact10,*) ( rdata(i), i=1, nv10 )


!     Test the data to insure that the trajectory resulted in valid criteria
!     being printed to the file.  This tolerance test was implemented
!     APR 92 when problems occurred.  Rdata and Ransave tested different
!     when they were supposed to be the same.  The differences resulted
!     from computer representation and the changes in the RDATA number
!     due to being written to the file, then read.

testvalue = ABS( rdata(kvar1) - ransave )

IF( testvalue > 0.01 ) THEN
  
!         The previously generated trajectory did not produce criteria
!         data.  The trajectory was halted prior to the tape 10  & 7
!         writes due to other reasons.  Back up toward the previous
!         "good" data
  
  goodat = .false.
  
ELSE
  
!         Valid criteria data was written to the tapes 10 & 7.
  
  goodat = .true.
  
!         Extract the criteria variable value calculated by the run
!         for testing in the calling module.
  
  critdat = rdata( krit )
  
END IF


RETURN
END SUBROUTINE swp_datchk

SUBROUTINE swp_do_sort( nrec )

!----------------------------------------------------------------------

!     This module performs a BUBBLE sort on the IMPACT7.ASC file to
!     make sure the data written to the IMPACT.ASC file is in the
!     correct order: increasing range, increasing angle.

!--Argument List Definitions-------------------------------------------

!  NREC         - (I) Number of trajectories on the IMPACT7.ASC file

!--Local Variable Definitions------------------------------------------

!  IPOS(100)    - (I) The array of trajectories in ascending range
!                 order
!  IRANGE       - (I) The array location in the plot variable list of
!                 the inner (range) variable
!  ITEMPOS      - (I) Temp trajectory number during bubble sort
!  PDATA(70)    - (R) The trajectory data written to scratch by module
!                 STGE3.  This data contains the criteria data value, the
!                 inner variable and the outer variable for that trajectory.
!  RSORTED(100) - (R) Array of sorted range values in ascending order
!  TEMPR        - (R) Temp Range value during bubble sort

!----------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: nrec
COMMON c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /opplot/  ipladd(70), intplot(70)
LOGICAL :: intplot

COMMON /oppltc/  alable
CHARACTER (LEN=1) :: alable(70)*8

!***  Input Data

EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(2280), nv     )

!      NV = The number of plot variables on the output files
!      RANGNO = The C element number of the inner variable

DIMENSION pdata(70), rsorted(100), ipos(100)

!     Rewind the IMPACT7.ASC file to ensure reading from the beginning
REWIND ( id_impact7 )

!---  Determine the Range position in the plot variables
DO i = 1, 70
  
  IF( ipladd( i ) == INT( rangno ) ) THEN
    irange = i
  END IF
  
END DO

!---  Read the range values into the sorted array
DO j = 1, nrec
  
READ(id_impact7,*, END = 100) (pdata(n), n=1, nv )
rsorted( j ) = pdata( irange )
ipos( j )    = j

END DO

!---  Sort the range array
100 DO k = (nrec-1),1,-1
  
  DO l = 1, k
    
    IF( rsorted( l ) > rsorted( l + 1 ) ) THEN
      tempr            = rsorted( l )
      rsorted( l )     = rsorted( l + 1 )
      rsorted( l + 1 ) = tempr
      itempos           = ipos( l )
      ipos( l )        = ipos( l + 1 )
      ipos( l + 1 )    = itempos
    END IF
    
  END DO
  
END DO

!     Transfer the data from file 7 (IMPACT7.ASC)
!     to file 22 (IMPACT.ASC)
CALL swp_7data45( nrec, ipos )

RETURN
END SUBROUTINE swp_do_sort

SUBROUTINE swp_end

!-------------------------------------------------------------------------

!  This module performs the shutdown procedure for the sweep
!  trajectories

!-------------------------------------------------------------------------


COMMON /fileflg/trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin
LOGICAL :: trajbin, trajasc, statbin, statasc, tabout,  &
    ranvar,  initasc, initbin, trackasc, trackbin

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!     Finished all trajectories - perform shutdown
!     prodecures.

!     Close the scratch files and the scratch output file.

CLOSE (id_impact10, STATUS = 'DELETE')
CLOSE (id_impact7, STATUS = 'DELETE')
CLOSE (id_impact)

!     NOTE:  Since these file are stopped by the modules and not the
!     executive, at this point, the data in the PMIN array is the
!     initial search values; Pmin contains 9999.9E38.  To prevent this
!     invalid data from causing problems with other programs, the last
!     -1.0 and max records are not going to be printed to the TRAJ.*
!     and STAT.* plot files.  This will not cause any problems with the
!     IPLT, etc series since they are always checking for EOF anyway.
!---  NOTE: Since converted from MS PowerStation 4.0 to Digital Visual FORTRAN
!           the ENDFILE statement was replaced with the CLOSE statement to
!           correctly disassociate the unit ID from the file without errors
!           for binary files. (The error was produced b/c the file was not opened
!           as a sequential file ?)   [BC 29 Sept 98]


IF( statbin ) CLOSE ( id_statbin )
IF( statasc ) CLOSE ( id_statasc )
IF( trajbin ) CLOSE ( id_trajbin )
IF( trajasc ) CLOSE ( id_trajasc )


STOP ' '
END SUBROUTINE swp_end

SUBROUTINE swp_findmiss( jgood, nextov, nextsr )

!-------------------------------------------------------------------------

!  Read the scratch file (unit 10) and load the final data from the
!  trajectories into the CDATA array.  Search the CDATA array for the
!  boundary from less than the user-entered critical value to greater
!  than this critical value.  NOTE:  This search assumes that the
!  trajectories near the maximum produced less-than-critical values and
!  trajectories near the minimum produced greater-than-critical values.

!--Argument List Definitions---------------------------------------------

!  JGOOD - (I) The trajectory number that produced a non-zero PCA.
!  NEXTOV - (L) Flag:  .FALSE. = The search criteria was satisfied -
!           start the binary search.  .TRUE. = Data satisfying the
!           criteria was not found - Increment to the next outer
!           variable.
!  NEXTSR - (L) Flag:  .TRUE. = The search critieria was satisified
!            continue the binary search.  .FALSE. = Data did not meet
!           search criteria continue along ray.  This flag is only used
!           for SWEEP5 methodology.

!--Local Variable Definitions--------------------------------------------

!  KRIT   - (I) Pointer into the RDATA array to the Criteria value.
!  ICOUNT - (I) Counter for the number of miss distances read into the
!           FMISS array.
!  NV10   - (I) The number of variables printed to the scratch file by
!           module STGE3.  The max number of variables in RDATA.
!  CDATA(70)  - (R) Array of criteria variable data produced by the
!               trajectory calculations and saved to the tape 10 file.
!  RDATA(3) - (R) Array of data generated at the end of the sweep runs.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: jgood
LOGICAL, INTENT(OUT)                     :: nextov
LOGICAL, INTENT(OUT)                     :: nextsr


COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(1805), critmax )

! CRITVAL = The minimum critical value for the criteria test.
! CRITMAX = The maximum critical value for the criteria test.


DIMENSION  cdata(70), rdata(3)

DATA krit/ 1 /, nv10/ 3 /


!---  Start searching at the beginning of the scratch file.
REWIND (id_impact10)

!---  Initialize the Trajectory counter.
icount = 0


!---  Read until end of scratch file.   Collect the criteria values.
1060 CONTINUE

!---  Read the data from the file.
READ(id_impact10,*,END=1080) ( rdata(i), i=1, nv10 )

!---  Increment record/trajecory counter
icount = icount + 1

IF( icount == 70 ) THEN
  
!---    Counter reached maximum array limits.  Produce error message
!---    and stop execution.
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) ' *** ERROR - NOT ENOUGH ARRAY ELEMENTS ',  &
      'FOR CRITERIA VALUES *** '
  WRITE(id_tabout,*)
  
  STOP ' '
END IF

!---  Extract the criteria values from the data and load it into the
!---  search array.
cdata( icount ) = rdata( krit )

!---  Go get the next record from the scratch file.
GO TO 1060


!---  End of IMPACT10 file.

1080 CONTINUE

!     Now - search the array of data to find the trajectory
!     number that produced the desired transition

!     Initialize the flags:

jgood = 1
nextov = .true.

!     Search BACKWARDS through the data.
!     Look for data greater than the critical value.    ******

DO i = icount, 1, -1
  
  IF( cdata(i) > critval ) THEN
    
!   This second test option was removed since CRITMAX could be
!   defaulted to 0.0 [BC 24 SEPT 98]
!  .AND. CDATA(I) .LT. CRITMAX ) THEN
    
!            Found the first data satisfying the criteria.
!            Set flags and stop search.
    
    jgood = i         ! Save the trajectory number.
    nextov = .false.  ! Set the flag.
    nextsr = .true.   ! Set the next bianry search flag for SWEEP5 only
    
    GO TO 1120      ! Stop the search.
  ELSE
    nextsr = .false.
  END IF
END DO


1120 CONTINUE


RETURN
END SUBROUTINE swp_findmiss

SUBROUTINE swp_findmiss5( jgood, nextov, nextsr )

!-------------------------------------------------------------------------

!  Read the scratch file (unit 10) and load the final data from the
!  trajectories into the CDATA array.  Search the CDATA array for the
!  boundary from greater than the user-entered critical value to less
!  than this critical value.  NOTE:  This search assumes that the
!  trajectories near the minimum produced less-than-critical values and
!  trajectories near the maximum produced greater-than-critical values.
!  This subroutine was added under XR97.

!--Argument List Definitions---------------------------------------------

!  JGOOD - (I) The trajectory number that produced a non-zero PCA.
!  NEXTOV - (L) Flag:  .FALSE. = The search criteria was satisfied -
!           start the binary search.  .TRUE. = Data satisfying the
!           criteria was not found - Increment to the next outer
!           variable.
!  NEXTSR - (L) Flag:  .TRUE. = The search critieria was satisified
!            continue the binary search.  .FALSE. = Data did not meet
!           search criteria continue along ray.  This flag is only used
!           for SWEEP5 methodology.

!--Local Variable Definitions--------------------------------------------

!  KRIT   - (I) Pointer into the RDATA array to the Criteria value.
!  ICOUNT - (I) Counter for the number of miss distances read into the
!           FMISS array.
!  NV10   - (I) The number of variables printed to the scratch file by
!           module STGE3.  The max number of variables in RDATA.
!  CDATA(70)  - (R) Array of criteria variable data produced by the
!               trajectory calculations and saved to the tape 10 file.
!  RDATA(3) - (R) Array of data generated at the end of the sweep runs.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: jgood
LOGICAL, INTENT(OUT)                     :: nextov
LOGICAL, INTENT(OUT)                     :: nextsr


COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(1805), critmax )

! CRITVAL = The minimum critical value for the criteria test.
! CRITMAX = The maximum critical value for the criteria test.


DIMENSION  cdata(70), rdata(3)

DATA krit/ 1 /, nv10/ 3 /


!---  Start searching at the beginning of the scratch file.
REWIND (id_impact10)

!---  Initialize the Trajectory counter.
icount = 0


!---  Read until end of scratch file.   Collect the criteria values.
1060 CONTINUE

!---  Read the data from the file.
READ(id_impact10,*,END=1080) ( rdata(i), i=1, nv10 )

!---  Increment record/trajecory counter
icount = icount + 1

IF( icount == 70 ) THEN
  
!---    Counter reached maximum array limits.  Produce error message
!---    and stop execution.
  WRITE(id_tabout,*)
  WRITE(id_tabout,*) ' *** ERROR - NOT ENOUGH ARRAY ELEMENTS ',  &
      'FOR CRITERIA VALUES *** '
  WRITE(id_tabout,*)
  
  STOP ' '
END IF

!---  Extract the criteria values from the data and load it into the
!---  search array.
cdata( icount ) = rdata( krit )

!---  Go get the next record from the scratch file.
GO TO 1060


!---  End of IMPACT10 file.

1080 CONTINUE

!     Now - search the array of data to find the trajectory
!     number that produced the desired transition

!     Initialize the flags:

jgood = 1
nextov = .true.

!     Search BACKWARDS through the data.
!     Look for data greater than the critical value.    ******

DO i = icount, 1, -1
  
  IF( cdata(i) < critval ) THEN
!  This second test option was removed since CRITMAX could be
!  defaulted to 0.0 [BC 24 SEPT 98]
! .AND. CDATA(I) .LT. CRITMAX ) THEN
    
!            Found the first data satisfying the criteria.
!            Set flags and stop search.
    
    jgood = i         ! Save the trajectory number.
    nextov = .false.  ! Set the flag.
    nextsr = .true.   ! Set the next bianry search flag for SWEEP5 only
    
    GO TO 1120      ! Stop the search.
  ELSE
    nextsr = .false.
  END IF
END DO


1120 CONTINUE


RETURN
END SUBROUTINE swp_findmiss5

SUBROUTINE swp_halfd( ransave, ranhalf )

!-------------------------------------------------------------------------

!  This module controlls the binary search.  The module checks the data
!  produced during the last trajectory.  The delta is halved, appropriately
!  signed, a new inner variable computed and the next trajectory is
!  setup for calculation.

!--Argument List Definitions---------------------------------------------

!  RANSAVE - (R) The inner loop variable value used in computing the
!            previous trajectory.
!  RANHALF - (R) The halfed delta; the delta that was used in computing
!            the previous trajectory and is being halfed during the binary
!            search.

!--Local Variable Definitions---------------------------------------------
!-------------------------------------------------------------------------


REAL, INTENT(OUT)                        :: ransave
REAL, INTENT(OUT)                        :: ranhalf
LOGICAL :: goodat

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(1805), critmax )

! CRITVAL = The minimum critical value for the criteria test.
! CRITMAX = The maximum critical value for the criteria test.


!---  Check to see if the trajectory produced good criteria data.
CALL swp_datchk( ransave, goodat, critdat )


IF( .NOT. goodat ) THEN
  
!---      The previously generated trajectory did not produce criteria
!---      data.  The trajectory was halted prior to the tape 10  & 7
!---      writes due to other reasons.  Back up toward the previous
!--       "good" data
  ranhalf = -1.0 * ABS( ranhalf ) * 0.5
  
ELSE
  
!---      Valid criteria data was written to the tapes 10 & 7.
  
!---      Test the data to see if it satisfies the criteria; adjust the sign
!---      appropriately.
  IF( critdat == critmax ) THEN  ! changed from .GT. to .EQ. [BC 24 SEPT 98]
    
!---          Added under XR97:
!---          The trajectory that produced this CRITDAT did not terminate at
!---          the correct end.  This is actually not good data.  This preserves
!             the SWEEP4 methodology since all data (even a complete miss) is
!             written to the IMPACT7 and IMPACT10 data files.
!---          Set the apprpriate flags and set up the next binarty search run
!---          as if bad data.
    goodat = .false.
    
!---          Back up towards the previous good data.
    ranhalf = -1.0 * ABS( ranhalf ) * 0.5
    
  ELSE IF( critdat <= critval ) THEN
    
!---          Critical data variable was less than the critical value
!---          Step back "in" to find a point closer to the critical
!---          value.
    ranhalf = -1.0 * ABS( ranhalf ) * 0.5
    
  ELSE
    
!---          Critical data variable is greater than the critical value.
!---          Step "out" to find a point closer to the critical value.
    ranhalf = ABS( ranhalf ) * 0.5
    
!---          The data is ASSUMED to hit:  Copy the data for a
!---          "hit" to the data file.
!---          NOTE ASSUMPTION:  Always step in from 'miss' and
!---          out after a 'hit'. (oked with XR - 14 APR 91)
!---          This code was taken out of the loop under XR97:
!---          All trajecotries need to be wriiten to the IMPACT.ASC
!---          even for complete miss trajectories, thus is this code
!---          was moved outside this IF loop
!              NDATA = 1
!              CALL SWP_7DATA( NDATA )
    
  END IF
  
END IF

!---  Write the data to the IMPACT.ASC file whether it was a "hit" or
!---  "miss"

!---  Comment out this CALL so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      NDATA = 1
!      CALL SWP_7DATA( NDATA )

!     Calculate the new delta.

ransave = ransave + ranhalf

!     During the binomal search, only keep the most current
!     trajectory results on BOTH the scratch tapes.

!---  Comment out this REWIND so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      REWIND ( ID_IMPACT7 )
REWIND ( id_impact10 )


!     Go calculate the new trajectory.

RETURN
END SUBROUTINE swp_halfd

SUBROUTINE swp_halfd5( ransave, ranhalf )

!-------------------------------------------------------------------------

!  This module controlls the binary search.  The module checks the data
!  produced during the last trajectory.  The delta is halved, appropriately
!  signed, a new inner variable computed and the next trajectory is
!  setup for calculation.  This subroutine halves the delta in the opposite
!  direction from that used in SWP_HALFD (added under XR97)

!--Argument List Definitions---------------------------------------------

!  RANSAVE - (R) The inner loop variable value used in computing the
!            previous trajectory.
!  RANHALF - (R) The halfed delta; the delta that was used in computing
!            the previous trajectory and is being halfed during the binary
!            search.

!--Local Variable Definitions---------------------------------------------
!-------------------------------------------------------------------------


REAL, INTENT(OUT)                        :: ransave
REAL, INTENT(OUT)                        :: ranhalf
LOGICAL :: goodat

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1802), critval )
EQUIVALENCE (c(1805), critmax )

! CRITVAL = The minimum critical value for the criteria test.
! CRITMAX = The maximum critical value for the criteria test.


!---  Check to see if the trajectory produced good criteria data.
CALL swp_datchk( ransave, goodat, critdat )


IF( .NOT. goodat ) THEN
  
!---      The previously generated trajectory did not produce criteria
!---      data.  The trajectory was halted prior to the tape 10  & 7
!---      writes due to other reasons.  Back up toward the previous
!--       "good" data
  ranhalf = -1.0 * ABS( ranhalf ) * 0.5
  
ELSE
  
!---      Valid criteria data was written to the tapes 10 & 7.
  
!---      Test the data to see if it satisfies the criteria; adjust the sign
!---      appropriately.
  IF( critdat == critmax ) THEN   ! changed from .GT. to .EQ. [BC 24 SEPT 98]
    
!---          Added under XR97:
!---          The trajectory that produced this CRITDAT did not terminate at
!---          the correct end.  This is actually not good data.  This preserves
!             the SWEEP4 methodology since all data (even a complete miss) is
!             written to the IMPACT7 and IMPACT10 data files.
!---          Set the apprpriate flags and set up the next binarty search run
!---          as if bad data.
    goodat = .false.
    
!---          Back up towards the previous good data.
    ranhalf = -1.0 * ABS( ranhalf ) * 0.5
    
  ELSE IF( critdat >= critval ) THEN
    
!---          Critical data variable was greater than the critical value
!---          Step back "in" to find a point closer to the critical
!---          value.
    ranhalf = -1.0 * ABS( ranhalf ) * 0.5
    
  ELSE
    
!---          Critical data variable is greater than the critical value.
!---          Step "out" to find a point closer to the critical value.
    ranhalf = ABS( ranhalf ) * 0.5
    
!---          The data is ASSUMED to hit:  Copy the data for a
!---          "hit" to the data file.
!---          NOTE ASSUMPTION:  Always step out from 'miss' and
!---          in after a 'hit'. (oked with XR - 14 APR 91)
!---          This code was taken out of the loop under XR97:
!---          All trajecotries need to be wriiten to the IMPACT.ASC
!---          even for complete miss trajectories, thus is this code
!---          was moved outside this IF loop
!              NDATA = 1
!              CALL SWP_7DATA( NDATA )
    
  END IF
  
END IF

!---  Write the data to the IMPACT.ASC file whether it was a "hit" or
!---  "miss"

!---  Comment out this CALL so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      NDATA = 1
!      CALL SWP_7DATA( NDATA )

!     Calculate the new delta.

ransave = ransave + ranhalf

!     During the binomal search, only keep the most current
!     trajectory results on BOTH the scratch tapes.

!---  Comment out this REWIND so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      REWIND ( ID_IMPACT7 )
REWIND ( id_impact10 )


!     Go calculate the new trajectory.

RETURN
END SUBROUTINE swp_halfd5

SUBROUTINE swp_initio

!-------------------------------------------------------------------------

!  This module opens the scratch files, opens the sweep output file and
!  copies the header files to the sweep output.

!-------------------------------------------------------------------------

COMMON c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /hcom/   title
CHARACTER (LEN=100) :: title

COMMON /oppltc/ alable
CHARACTER (LEN=1) :: alable(70)*8


!***  Input from other modules

EQUIVALENCE (c(2280), nv )


INTEGER :: getenvqq
CHARACTER (LEN=50) :: filename chara ter*8 cjunk8
DATA cjunk8 / '        '/


!---  Open some scratch files used in the sweep case.
OPEN( UNIT=id_impact10, FILE='IMPACT10.ASC', STATUS='UNKNOWN' )
OPEN( UNIT=id_impact7,  FILE='IMPACT7.ASC',  STATUS='UNKNOWN' )

!     Open the Sweep end data file:
!------------------------PC Code-------------------------------------

!---       LENGTH = GETENVQQ( 'IMPACT', FILENAME )
length = 0
IF( length == 0 ) filename = 'impact.ASC'

OPEN( UNIT=id_impact, FILE = filename( 1: lenstr(filename)),  &
    STATUS = 'UNKNOWN' )


!---  On Dec 1994 Dr. Zipfel wanted the option of not creating a traj.bin
!---  Therefore, the title, acronyms and number of acronyms need to be
!---  obtained from the common variables and the code where the
!---  information is obtained from the traj.bin file has been commented out.

!---  Copy the file title and acronyms from the traj.bin.
!      REWIND ( ID_TRAJBIN )
!      READ(ID_TRAJBIN) TITLE
!---  Set the first character of the title to '1' since the sweep output
!---  is in ascii
!      TITLE = '1' // TITLE(1:99)
!      WRITE(ID_SWEEP,'(A)' ) TITLE
!      READ(ID_TRAJBIN) IN1, IN2, IN3
!      WRITE(ID_SWEEP,*) IN1, IN2, IN3
!      READ(ID_TRAJBIN) ( ALABLE(I), SPACE, I = 1, NV )
!      WRITE(ID_SWEEP,100) ( ALABLE(I), I = 1, NV )
!  100 FORMAT( 5( A8, 8X ) )


REWIND ( id_impact )

WRITE(id_impact,100 ) '1', title
100 FORMAT( a, a )

!CCCCCGAB ADDED NV INPLACE OF C(2280) IN THE FOLLOWING WRITE STATEMENT
WRITE(id_impact,110) INT( c(1982) ), INT( c(1983)), nv
110 FORMAT( 1X, 3(i2,1X))

!CCCCCGAB ADDED NV INPLACE OF C(2280) IN THE FOLLOWING WRITE STATEMENT
WRITE(id_impact,120) ( alable(j), cjunk8, j=1, nv )
120 FORMAT( 5( a8, a8 ) )


!---  Rewind the scratch files to insure starting at begining.
REWIND ( id_impact10 )
REWIND ( id_impact7  )


RETURN
END SUBROUTINE swp_initio

SUBROUTINE swp_isearch( jgood, ransave, ranhalf )

!-------------------------------------------------------------------------

!  This module sets up the first trajectory in the binary search.

!--Argument List Definitions--------------------------------------------

!  INRUNNO - (I) The trajectory number for the inner loop variable.
!  RANSAVE - (R) The inner variable value used in computing the previous
!            trajectory.
!  RANHALF - (R) The halfed delta; the delta to be used in the binary
!            search trajectories that will be halfed accordingly.  Also
!            the delta used in computing the previous trajectory.

!--Local Variable Definitions---------------------------------------------

!  KRANG    - (I) Pointer into the RDATA array to the inner loop
!             variable value.
!  KRIT     - (I) Pointer into the RDATA array to the critical data
!             value produced by the trajectory.
!  NV10     - (I) The number of variables written to the scratch file by
!             module STGE3.  The max number of variables in RDATA.
!  RDATA(3) - (R) The final trajectory data written to scratch by module
!             STGE3.  This data contains the criteria data value, the
!             inner variable and the outer variable for that trajectory.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: jgood
REAL, INTENT(OUT)                        :: ransave
REAL, INTENT(OUT)                        :: ranhalf
COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1824), randel )

! RANDEL = The delta for the inner variable.


DIMENSION rdata(3)

!     DATA  KRIT/ 1 /                    ! Not used in this module.
DATA   krang/ 2 /, nv10/ 3 /


!---  Rewind the scratch file and read to the data that generated
!---  the good trajectory.
REWIND ( id_impact10 )

DO i = 1, jgood
  READ(id_impact10,*, END= 1140 ) (rdata(j), j=1, nv10 )
END DO


!---  Transfer the plot variable data from the scratch file 7 to the
!---  IMPACT7.
!---  Comment out this CALL so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      CALL SWP_7DATA( JGOOD )



1140 CONTINUE


!---  Rewind the scratch files for the start of:
!---  either the next ray data, or the search data.

REWIND (id_impact10)
!---  Comment out this REWIND so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      REWIND (ID_IMPACT7)


!---  Setup the first trajectory for the binary search methodology.
!     Half the inner variable increment.

ranhalf = randel * 0.5

!     Get the last initial inner variable value that produced a
!     trajectory that satisfied the criteria.
!     Remember - in the above read statements, RDATA was loaded
!     with the JGOODth trajectory data.

ransave = rdata( krang )

!     Compute the range for the next trajectory.  This is found from the
!     range that satisfied the criteria, then adding the new increment.

ransave = ransave + ranhalf


RETURN
END SUBROUTINE swp_isearch

SUBROUTINE swp_isearch5( ibound, jgood, ransave, ranhalf )

!-------------------------------------------------------------------------

!  This module sets up the first trajectory in the binary search for
!  SWEEP mode 5.

!--Argument List Definitions--------------------------------------------

!  IBOUND   - (I) The boundary for which the searches will try to locate:
!             Boundary 1:  Inner Boundary or Second hole/bayou boundary
!             Boundary 2:  Hole or Bayou
!  JGOOD - (I) The trajectory number that produced a non-zero PCA.
!  RANSAVE - (R) The inner variable value used in computing the previous
!            trajectory.
!  RANHALF - (R) The halfed delta; the delta to be used in the binary
!            search trajectories that will be halfed accordingly.  Also
!            the delta used in computing the previous trajectory.

!--Local Variable Definitions---------------------------------------------

!  KRANG    - (I) Pointer into the RDATA array to the inner loop
!             variable value.
!  KRIT     - (I) Pointer into the RDATA array to the critical data
!             value produced by the trajectory.
!  NV10     - (I) The number of variables written to the scratch file by
!             module STGE3.  The max number of variables in RDATA.
!  RDATA(3) - (R) The final trajectory data written to scratch by module
!             STGE3.  This data contains the criteria data value, the
!             inner variable and the outer variable for that trajectory.

!-------------------------------------------------------------------------


INTEGER, INTENT(IN)                      :: ibound
INTEGER, INTENT(IN)                      :: jgood
REAL, INTENT(OUT)                        :: ransave
REAL, INTENT(OUT)                        :: ranhalf
COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1824), randel )
EQUIVALENCE (c(1802), critval )

! CRITVAL = The minimum critical value for the criteria test.
! RANDEL = The delta for the inner variable.


DIMENSION rdata(3)

DATA  krit/ 1 /
DATA  krang/ 2 /, nv10/ 3 /


!---  Rewind the scratch file and read to the data that generated
!---  the good trajectory.
REWIND ( id_impact10 )

DO i = 1, jgood
  READ(id_impact10,*, END= 1140 ) (rdata(j), j=1, nv10 )
END DO


!---  Transfer the plot variable data from the scratch file 7 to the
!---  IMPACT7.
!---  Comment out this CALL so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      CALL SWP_7DATA( JGOOD )



1140 CONTINUE


!---  Rewind the scratch files for the start of:
!---  either the next ray data, or the search data.

REWIND (id_impact10)
!---  Comment out this REWIND so that all impact data will be written
!---  from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---  searches.  This done under XR97
!      REWIND (ID_IMPACT7)


!---  Setup the first trajectory for the binary search methodology.
!     Half the inner variable increment.

ranhalf = randel * 0.5

!     Get the last initial inner variable value that produced a
!     trajectory that satisfied the criteria.
!     Remember - in the above read statements, RDATA was loaded
!     with the JGOODth trajectory data.

ransave = rdata( krang )

!     Compute the range for the next trajectory.  This is found from the
!     range that satisfied the criteria, then adding the new increment.
!     Add or subtract according to the boundary number, IBOUND
!         IBOUND = 1 ==> Subtract half delta
!         IBOUND = 2 ==> Add half delta

IF( ibound == 1 ) THEN
  
!         Check direction of half delta based on value of critical variable
  IF( rdata(krit) < critval ) THEN
    ransave = ransave - ranhalf
  ELSE
    ransave = ransave + ranhalf
  END IF
  
ELSE IF( ibound == 2 ) THEN
  
!         Check direction of half delta based on value of critical variable
  IF( rdata(krit) > critval ) THEN
    ransave = ransave - ranhalf
  ELSE
    ransave = ransave + ranhalf
  END IF
  
END IF


RETURN
END SUBROUTINE swp_isearch5

SUBROUTINE swp_nextov( inrunno, outrunno, angsave )

!-------------------------------------------------------------------------

!  This module increments the outer variable, rewinds all scratch files
!  and sets the flags for the first trajectory in the next ray and
!  checks the outer variable for the end of the runs.

!--Argument List Definition---------------------------------------------

!  INRUNNO  - (I) The counter for the inner variable trajectories.
!  OUTRUNNO - (I) The counter for the outer variable.
!  ANGSAVE  - (R) The current value for the outer variable.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: inrunno
INTEGER, INTENT(OUT)                     :: outrunno
REAL, INTENT(OUT)                        :: angsave


COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

!***  Input

EQUIVALENCE (c(1813), angmax )
EQUIVALENCE (c(1814), angdel )

! ANGMAX = The maximum value for the outer variable.
! ANGDEL = The delta for the outer variable.


!---  Rewind all scratch files for the next ray.
REWIND id_impact7
REWIND id_impact10     ! Restart the criteria tape.

!---  Increment the outer variable.
angsave = angsave + angdel

!---  Test the outer loop variable against the max value input
!---  by the user.
IF( angsave <= angmax ) THEN
  
!         Have not reached the maximum outer loop variable.
!         Initialize variables for the new ray calculations.
  
  outrunno = outrunno + 1
  
!         Reset the inner loop counter
  
  inrunno  = 0
  
ELSE
  
!         Finished all trajectories - perform shutdown
!         prodecures.
  
  CALL swp_end
  
END IF


RETURN
END SUBROUTINE swp_nextov

SUBROUTINE swp_runinit( inrunno, outrunno, angsave )

!-------------------------------------------------------------------------

!  This module initializes flags for counting the trajectories and
!  opens the output files.

!--Argument List Definition---------------------------------------------

!  INRUNNO - (I) Counter for the inner loop trajectories.
!  OUTRUNNO - (I) Counter for the outer loop trajectories.
!  ANGSAVE - (R)  The saved value of the outer variable used in the last
!            calculated trajectories.

!-------------------------------------------------------------------------


INTEGER, INTENT(OUT)                     :: inrunno
INTEGER, INTENT(OUT)                     :: outrunno
REAL, INTENT(OUT)                        :: angsave



COMMON  c(3510)

!***  Input

EQUIVALENCE (c(1812), angmin )


!     First time through the sweep algorithm

outrunno = 1
inrunno = 0

!     Initialize the I/O files.

CALL swp_initio

!     Save the outer loop variable for this trajectory.

angsave = angmin


RETURN
END SUBROUTINE swp_runinit

SUBROUTINE sweep0_method

!-------------------------------------------------------------------------

!  This module contains the controlling methodology for the CADAC
!  Sweep option 0.   In this method, NUMR trajectories are calculated
!  at equally spaced intervals between the minimum and maximum values for
!  the inner variable.  (NUMR is entered by the user)   NO criteria
!  checking is performed in this option.

!  TASK XR97:
!    Under this task, the program was modified to check the CRITMAX value
!    If this value was not set using the CADIN.ASC file, set it to
!    CRITVAL + 9.0E+05

!  TASK XR92:
!    Under this task, the program was modified to allow multi-run/Monte-
!    Carlo option and Sweeps option selected in the same input deck.  When
!    this occurs then allow the increment of the range and angle variables
!    to occur only when JRUN = 1.  For other values of JRUN, the
!    same angle and range are to be used until the number of runs for
!    the "sweep group" have been completed.  Be careful - If the type 5
!    card is omitted from the input deck, the range and angle must still
!    be incremented for each (JRUN) trajectory.


!-------------------------------------------------------------------------

!  INRUNNO  - (I) The run number for the inner loop variable.
!  OUTRUNNO - (I) The counter for the outer loop variable.
!  RANSAVE  - (R) The range(inner variable value) for the current
!             trajectory
!  ANGSAVE  - (R) The angle(outer variable value) for the current
!             trajectory.

!-------------------------------------------------------------------------

INTEGER :: outrunno

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/   jrun, mulrun, igroup


!***  Input

EQUIVALENCE (c(1804), numr   )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )

! NUMR =   The number of trajectories to be generated per ray.
! ANGLNO = The C element number for the outer variable.
! RANGNO = The C element number for the inner variable.
! RANMIN = The minimum value for the inner variable.
! RANMAX = The maximum value for the inner variable.

!---  Remember:  Ransave and Angsave are local to this module and will
!---  contain the same values upon return to this module


IF( mulrun > 0  .AND. jrun /= 1 ) THEN
  
!---    This is a multi-run/MonteCarlo sweep case.  A type 5 card
!---    and sweep cards are included on the same deck.
  
!---    However - This particular trajectory is one of a group of
!---    trajectories.  It is not the FIRST of the group since Jrun is
!---    greater than 1.  Insure that the data generated by previously
!---    trajectories is printed to the IMPACT.ASC file.
  ndata = 1
  CALL swp_7data( ndata )
  
  
ELSE
  
  
!---    Two instances have occurred:
!---      1) A SINGLE Sweep case is being executed (ie. Monte-Carlo
!---         /multi-run cases are NOT being executed with Sweep -
!---         the type 5 card was omitted from the input deck)
!---      2) Multi-runs/Monte-Carlo and Sweep are being executed in
!---         the same input deck AND This is the first trajectory for
!---         this `Sweep group' and the range and angle need to be set.
  
  IF( outrunno < 1 ) THEN
    
!---      First time through the sweep algorithm - init flags:
    CALL swp_runinit( inrunno, outrunno, angsave )
    
    IF( numr < 1 ) THEN
      
!---        Only 1 trajectory was requested.
      WRITE(id_tabout,*)
      WRITE(id_tabout,*)' *** OPTION0 SWP1 ERROR -  NUMR <= 0 ***'
      WRITE(id_tabout,*)'    PROGRAM EXECUTION STOPPED '
      WRITE(id_tabout,*)
      
      CALL swp_end
      
    END IF
    
  ELSE
    
!---      Time to setup first trajectory for the next outer variable
!---      value.  But first - Print the last trajectory plot data
!---      to the file.
    ndata = 1
    CALL swp_7data( ndata )
    
  END IF
  
  
  100   CONTINUE
  
!---    Set the maximum critical variable, CRITMAX
  CALL swp_critcheck
  
  IF(  inrunno < 1 ) THEN
    
!---      The first trajectory for the inner variable.
!---      Calculate the delta range for the increment.  Since the C
!---      array is zeroed at the start of each trajectory, don't save
!---      this in the RANDEL location.  Save it in a local variable.
    IF( numr < 2 ) THEN
      
!---        Only one trajectory is requested.  Set the delta to
!---        a value larger than the maximum range.
      srandel = ranmax + 100
      
    ELSE IF( numr < 3 ) THEN
      
!---        Numr = 2 :  Special case and SRANDEL calculation fails
!---        to provide the correct value.  Set the SRANDEL to provide
!---        a trajectory at each endpoint.
      srandel = ranmax - ranmin
      
    ELSE
      
!---        Multiple trajectories - calculate the delta.
      srandel = ( ranmax - ranmin ) / ( numr - 1 )
      
    END IF
    
!---      Save the inner loop variable value for this trajectory.
    ransave = ranmin
    
    
  ELSE
    
    IF( inrunno < numr  ) THEN
      
!---        Not finished with runs along this ray. Increment inner variable.
      ransave = ransave + srandel
      
    ELSE
      
!---        Finished the trajectories for the inner variable.
!---        Increment the local variables for the next trajectory.
      CALL swp_nextov( inrunno, outrunno, angsave )
      
      GO TO 100
      
    END IF
    
    
  END IF
  
!---    Increment the inner variable counter.
  inrunno = inrunno + 1
  
END IF

!---  End of check for single sweep or first sweep of a group

!     The new RANSAVE value has been "set".  Set the C location,
!     perform the requried print to the data file, then go perform
!     the trajectory calculation.

!     Initialize the outer loop variable.  This needs to be
!     initialized for each trajectory since the C array is zeroed
!     prior to each trajectory calculation.

c( INT(anglno) ) = angsave

!     Initialize the inner loop element.

c( INT(rangno) ) = ransave

!     Write the new conditions to the tabular file.

CALL swp_6print( inrunno )


!     Calculate the trajectory for this initial information.

RETURN
END SUBROUTINE sweep0_method

SUBROUTINE sweep1_method

!-------------------------------------------------------------------------

!  This module contains the controlling methodology for the CADAC
!  Sweep option 1.   In this method, NUMR trajectories are calculated
!  at intervals between the minimum and maximum values for the inner
!  variable.  (NUMR is entered by the user;  NUMR > 3 is recommended)
!  As the inner loop maximum is reached, the inner loop delta becomes
!  smaller.  NO criteria checking is performed in this option.

!  TASK XR97:
!    Under this task, the program was modified to check the CRITMAX value
!    If this value was not set using the CADIN.ASC file, saet it to
!    CRITVAL + 9.0E+05

!  TASK XR92:
!    Under this task, the program was modified to allow multi-run/Monte-
!    Carlo option and Sweeps option selected in the same input deck.  When
!    this occurs then allow the increment of the range and angle variables
!    to occur only when JRUN = 1.  For other values of JRUN, the
!    same angle and range are to be used until the number of runs for
!    the "sweep group" have been completed.  Be careful - If the type 5
!    card is omitted from the input deck, the range and angle must still
!    be incremented for each (JRUN) trajectory.


!-------------------------------------------------------------------------

!  INRUNNO  - (I) The run number for the inner loop variable.
!  OUTRUNNO - (I) The counter for the outer loop variable.
!  RANSAVE  - (R) The range(inner variable value) for the current
!             trajectory
!  ANGSAVE  - (R) The angle(outer variable value) for the current
!             trajectory.

!-------------------------------------------------------------------------

INTEGER :: outrunno

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin


COMMON /krun/   jrun, mulrun, igroup

!***  Input

EQUIVALENCE (c(1804), numr   )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )

! NUMR =   The number of trajectories to be generated per ray.
! ANGLNO = The C element number for the outer variable.
! RANGNO = The C element number for the inner variable.
! RANMIN = The minimum value for the inner variable.
! RANMAX = The maximum value for the inner variable.

!---   Remember:  Ransave and Angsave are local to this module and will
!---   contain the same values upon return to this module

IF( mulrun > 0  .AND. jrun /= 1 ) THEN
  
!---    This is a multi-run/MonteCarlo sweep case.  A type 5 card
!---    and sweep cards are included on the same deck.
!---    However - This particular trajectory is one of a group of
!---    trajectories.  It is not the FIRST of the group since Jrun is
!---    greater than 1.  Insure that the data generated by previously
!---    trajectories is printed to the IMPACT.ASC file.
  
  ndata = 1
  CALL swp_7data( ndata )
  
  
ELSE
  
!---    Two instances have occurred:
!---      1) A SINGLE Sweep case is being executed (ie. Monte-Carlo
!---         /multi-run cases are NOT being executed with Sweep -
!---         the type 5 card was omitted from the input deck)
!---      2) Multi-runs/Monte-Carlo and Sweep are being executed in
!---         the same input deck AND This is the first trajectory for
!---         this `Sweep group and the range and angle need to be set.
  
  IF( outrunno < 1 ) THEN
    
!---      First time through the sweep algorithm - init flags:
    CALL swp_runinit( inrunno, outrunno, angsave )
    
    
    IF( numr < 1 ) THEN
      
!---        No trajectories were selected to be executed!
      WRITE(id_tabout,*)
      WRITE(id_tabout,*)' *** OPTION1 SWP1 ERROR -  NUMR <= 0 ***'
      WRITE(id_tabout,*)'    PROGRAM EXECUTION STOPPED '
      WRITE(id_tabout,*)
      
      CALL swp_end
    END IF
    
  END IF
  
  
  100   CONTINUE
  
!---    Set the maximum critical value, CRITMAX
  CALL swp_critcheck
  
  IF(  inrunno < 1 ) THEN
    
!---      The first trajectory for the inner variable.
!---      Insure that the number of trajectories is odd.
    newnumr = numr + 2
    
!---      Calculate the mid-point for the inner loop variable:
    rmidpt = ( ranmax - ranmin ) / 2.0
    
!---      Calculate an equation part for the delta-modifying algorithm:
    partr1 = (rmidpt * rmidpt) * ( 1.0 + ( 2.0 / newnumr ) )
    
!---      Calculate the inner loop variable value for this trajectory.
    ransave = ranmin + rmidpt
    
!---      Since the C array is zeroed at the start of each trajectory,
!---      don't save this in the RANDEL location.  Save it in a local
!---      variable.
!---      Calculate the modifying delta for this trajectory:
    
    srandel = rmidpt
    
    
  ELSE IF( inrunno < numr ) THEN
    
!---      Print the previously generated trajectory plot data to the file.
    ndata = 1
    CALL swp_7data( ndata )
    
!---      Not finished with the runs along this ray.
!---      Calculate the next inner variable value
    
!---      Calculate the modifying delta for this trajectory:
!---      NOTE: This algorithm was used in CADAC for this purpose
!---      prior to task SEU 9108.
    
    part3   = 2 * rmidpt * srandel
    srandel2 = srandel * srandel
    
    srandel = rmidpt + SQRT( partr1 + srandel2 - part3 )
    
!---      Calculate the inner loop variable value for this trajectory.
    ransave = ranmin + srandel
    
    
  ELSE
    
!---      Print the previously generated trajectory plot data to
!---      the file.
    ndata = 1
    CALL swp_7data( ndata )
    
!---      Increment the outer variable.
    CALL swp_nextov( inrunno, outrunno, angsave )
    
    GO TO 100
    
  END IF
  
  
!---    Increment the inner variable counter.
  inrunno = inrunno + 1
  
END IF


!---  Initialize the outer loop variable.  This needs to be initialized
!---  for each trajectory since the C array is zeroed prior to each
!---  trajectory calculation.
c( INT(anglno) ) = angsave

!---  Initialize the inner loop element.
c( INT(rangno) ) = ransave

!---  Write the new conditions to the tabular file.
CALL swp_6print( inrunno )


RETURN
END SUBROUTINE sweep1_method

SUBROUTINE sweep2_method

!-------------------------------------------------------------------------

!  This module contains the controlling methodology for the CADAC
!  Sweep option 2.   In this method, NUMR trajectories are calculated
!  at intervals between the minimum and maximum values for the inner
!  variable.  (NUMR is entered by the user)   As the inner loop maximum is
!  reached, the inner loop delta becomes larger.  NO criteria
!  checking is performed in this option.

!  TASK XR97:
!    Under this task, the program was modified to check the CRITMAX value
!    If this value was not set using the CADIN.ASC file, saet it to
!    CRITVAL + 9.0E+05

!  TASK XR92:
!    Under this task, the program was modified to allow multi-run/Monte-
!    Carlo option and Sweeps option selected in the same input deck.  When
!    this occurs then allow the increment of the range and angle variables
!    to occur only when JRUN = 1.  For other values of JRUN, the
!    same angle and range are to be used until the number of runs for
!    the "sweep group" have been completed.  Be careful - If the type 5
!    card is omitted from the input deck, the range and angle must still
!    be incremented for each (JRUN) trajectory.


!-------------------------------------------------------------------------

!  INRUNNO  - (I) The run number for the inner loop variable.
!  OUTRUNNO - (I) The counter for the outer loop variable.
!  RANSAVE  - (R) The range(inner variable value) for the current
!             trajectory
!  ANGSAVE  - (R) The angle(outer variable value) for the current
!             trajectory.

!-------------------------------------------------------------------------

INTEGER :: outrunno

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/   jrun, mulrun, igroup


!***  Input

EQUIVALENCE (c(1804), numr   )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )

! NUMR =   The number of trajectories to be generated per ray.
! ANGLNO = The C element number for the outer variable.
! RANGNO = The C element number for the inner variable.
! RANMIN = The minimum value for the inner variable.
! RANMAX = The maximum value for the inner variable.

!---   Remember:  Ransave and Angsave are local to this module and will
!---   contain the same values upon return to this module


IF( mulrun > 0  .AND. jrun /= 1 ) THEN
  
!---    This is a multi-run/MonteCarlo sweep case.  A type 5 card
!---    and sweep cards are included on the same deck.
  
!---    However - This particular trajectory is one of a group of
!---    trajectories.  It is not the FIRST of the group since Jrun is
!---    greater than 1.  Insure that the data generated by previously
!---    trajectories is printed to the IMPACT.ASC file.
  ndata = 1
  CALL swp_7data( ndata )
  
  
ELSE
  
!       Two instances have occurred:
!---      1) A SINGLE Sweep case is being executed (ie. Monte-Carlo
!---         /multi-run cases are NOT being executed with Sweep -
!---         the type 5 card was omitted from the input deck)
!---      2) Multi-runs/Monte-Carlo and Sweep are being executed in
!---         the same input deck AND This is the first trajectory for
!---         this `Sweep group and the range and angle need to be set.
!---
  
  IF( outrunno < 1 ) THEN
    
!---      First time through the sweep algorithm - init flags:
    CALL swp_runinit( inrunno, outrunno, angsave )
    
    IF( numr < 1 ) THEN
      
!---        No trajectories were selected to be executed!
      WRITE(id_tabout,*)
      WRITE(id_tabout,*)' *** OPTION2 SWP1 ERROR -  NUMR <= 0 ***'
      WRITE(id_tabout,*)'    PROGRAM EXECUTION STOPPED '
      WRITE(id_tabout,*)
      
      CALL swp_end
      
    END IF
    
  END IF
  
  
  100   CONTINUE
  
!---    Set the maximum critical value, CRITMAX
  CALL swp_critcheck
  
  IF(  inrunno < 1 ) THEN
    
!---      The first trajectory for the inner variable. Modify the
!---      number to obtain the requested number of trajectories.
    newnumr = numr + 2
    
!---      Calculate the mid-point for the inner loop variable:
    rmidpt = ( ranmax - ranmin ) / 2.0
    
!---      Calculate the number of runs to the midpoint:
    midrun = ( newnumr + 1 ) / 2
    
!---      Calculate a part of the delta-modifying algorithm:
    partr2 = (rmidpt * rmidpt) * ( 1.0 -( 2.0 / newnumr ) )
    
!---      Since the C array is zeroed at the start of each trajectory,
!---      don't save this in the RANDEL location.  Save it in a local
!---      variable.
    
!---      Calculate the modifying delta for this trajectory:
    srandel = 0.0
    
!---      Calculate the inner loop variable value for this trajectory.
    ransave = ranmin
    
    
  ELSE IF( inrunno < numr  .AND.  inrunno <= midrun ) THEN
    
!---      Transfer the previously calculated data
    ndata = 1
    CALL swp_7data( ndata )
    
!---      Not finished with the runs along this ray.
!---      Calculate the next inner variable value
!---      Calculate the modifying delta for this trajectory:
    part3    = 2 * rmidpt * srandel
    srandel2 = srandel * srandel
    sqvalue  = partr2 + srandel2 - part3
    
!---      Careful - cant take square root of 0:
    
    IF( sqvalue > 0.0 ) THEN
      
!---        Value not yet zero - can take square root:
      srandel = rmidpt - SQRT( sqvalue )
      
    ELSE
      
!---        Reached the midpoint
      srandel = rmidpt
      
    END IF
    
!---      Calculate the inner loop variable value for this trajectory.
    ransave = ranmin + srandel
    
    
  ELSE
    
!---      Transfer the previously calculated data
    ndata = 1
    CALL swp_7data( ndata )
    
    CALL swp_nextov( inrunno, outrunno, angsave )
    
    GO TO 100
    
  END IF
  
  
!---    Increment the inner variable counter.
  inrunno = inrunno + 1
  
END IF

!---  Initialize the outer loop variable.  This needs to be initialized
!---  for each trajectory since the C array is zeroed prior to each
!---  trajectory calculation.
c( INT(anglno) ) = angsave

!---  Initialize the inner loop element.
c( INT(rangno) ) = ransave

!---  Write the new conditions to the tabular file.
CALL swp_6print( inrunno )


RETURN
END SUBROUTINE sweep2_method

SUBROUTINE sweep3_method

!-------------------------------------------------------------------------

!  This module contains the controlling methodology for the CADAC
!  Sweep option 3.   In this method, NUMR trajectories are calculated
!  at intervals between the minimum and maximum values for the inner
!  variable.  (NUMR is entered by the user)   This methodology uses a
!  small inner variable delta near the  minimum and maximum values and a
!  larger delta near the midpoint.  NO criteria checking is performed in
!  this option.

!  TASK XR97:
!    Under this task, the program was modified to check the CRITMAX value
!    If this value was not set using the CADIN.ASC file, saet it to
!    CRITVAL + 9.0E+05

!  TASK XR92:
!    Under this task, the program was modified to allow multi-run/Monte-
!    Carlo option and Sweeps option selected in the same input deck.  When
!    this occurs then allow the increment of the range and angle variables
!    to occur only when JRUN = 1.  For other values of JRUN, the
!    same angle and range are to be used until the number of runs for
!    the "sweep group" have been completed.  Be careful - If the type 5
!    card is omitted from the input deck, the range and angle must still
!    be incremented for each (JRUN) trajectory.


!-------------------------------------------------------------------------

!  INRUNNO  - (I) The run number for the inner loop variable.
!  OUTRUNNO - (I) The counter for the outer loop variable.
!  RANSAVE  - (R) The range(inner variable value) for the current
!             trajectory
!  ANGSAVE  - (R) The angle(outer variable value) for the current
!             trajectory.

!-------------------------------------------------------------------------

INTEGER :: outrunno

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/   jrun, mulrun, igroup


!***  Input

EQUIVALENCE (c(1804), numr   )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )

! NUMR =   The number of trajectories to be generated per ray.
! ANGLNO = The C element number for the outer variable.
! RANGNO = The C element number for the inner variable.
! RANMIN = The minimum value for the inner variable.
! RANMAX = The maximum value for the inner variable.

!---   Remember:  Ransave and Angsave are local to this module and will
!---   contain the same values upon return to this module


IF( mulrun > 0  .AND. jrun /= 1 ) THEN
  
!---      This is a multi-run/MonteCarlo sweep case.  A type 5 card
!---      and sweep cards are included on the same deck.
  
!---      However - This particular trajectory is one of a group of
!---      trajectories.  It is not the FIRST of the group since Jrun is
!---      greater than 1.  Insure that the data generated by previously
!---      trajectories is printed to the IMPACT.ASC file.
  
  ndata = 1
  CALL swp_7data( ndata )
  
  
ELSE
  
  
!         Two instances have occurred:
!           1) A SINGLE Sweep case is being executed (ie. Monte-Carlo
!              /multi-run cases are NOT being executed with Sweep -
!              the type 5 card was omitted from the input deck)
!           2) Multi-runs/Monte-Carlo and Sweep are being executed in
!              the same input deck AND This is the first trajectory for
!              this `Sweep group and the range and angle need to be set.
  
  
  IF( outrunno < 1 ) THEN
    
!             First time through the sweep algorithm - init flags:
    
    CALL swp_runinit( inrunno, outrunno, angsave )
    
    
    IF( numr < 1 ) THEN
      
!                 No trajectories were selected to be executed!
      
      WRITE(id_tabout,*)
      WRITE(id_tabout,*) ' *** OPTION3 SWP1 ERROR -  NUMR <= 0 ***'
      WRITE(id_tabout,*) '    PROGRAM EXECUTION STOPPED '
      WRITE(id_tabout,*)
      
      CALL swp_end
      
    END IF
    
  END IF
  
  
  100     CONTINUE
  
!---      Set the maximum critical value
  CALL swp_critcheck
  
  IF(  inrunno < 1 ) THEN
    
!              The first trajectory for the inner variable.
!              Calculate the integer required to calculate the
!              smaller -> larger deltas
    
    newnumr = numr + 2
    
!              Calculate the mid-point for the inner loop variable:
    
    rmidpt = ( ranmax - ranmin ) / 2.0
    
!              Calculate the number of runs to the midpoint:
    
    midrun = ( numr + 1 ) / 2
    
!              Calculate the factors for the delta-modifying algorithm:
    
    partr1 = (rmidpt * rmidpt) * ( 1.0 +( 2.0 / newnumr ) )
    partr2 = (rmidpt * rmidpt) * ( 1.0 -( 2.0 / newnumr ) )
    
!              Since the C array is zeroed at the start of each trajectory,
!              don't save this in the RANDEL location.  Save it in a local
!              variable.
!              Calculate the modifying delta for this trajectory:
    
    srandel = 0.0
    
!              Calculate the inner loop variable value for this trajectory.
    
    ransave = ranmin
    
    
  ELSE IF( inrunno < numr   .AND.  inrunno < midrun ) THEN
    
!              The trajectories prior to the midpoint are being calculated.
!              Transfer the previously calculated data
    
    ndata = 1
    CALL swp_7data( ndata )
    
!              Not finished with the runs along this ray.
!              Calculate the next inner variable value
    
!              Previous inner variable was less than the midpoint.
!              Use the algorithm for increasing deltas.
    
    part3 = 2 * rmidpt * srandel
    srandel2 = srandel * srandel
    sqvalue = partr2 + srandel2 - part3
    
!              Careful - cant take square root of 0:
    
    IF( sqvalue > 0.0 ) THEN
      
!                  Value not yet zero - can take square root:
      
      srandel = rmidpt - SQRT( sqvalue )
      
    ELSE
      
!                  Reached the midpoint
      
      srandel = rmidpt
      
    END IF
    
!              Calculate the inner loop variable value for this trajectory.
    
    ransave = ranmin + srandel
    
    
  ELSE IF( inrunno < numr   ) THEN
    
!              Calculate the trajectories after the midpoint.
!              Transfer the previously calculated data
    
    ndata = 1
    CALL swp_7data( ndata )
    
!              Not finished with the runs along this ray.
!              Calculate the next inner variable value
    
!              Calculate the modifying delta for this trajectory:
!              Previous inner variable was greater than the midpoint
!              Use the algorithm for decreasing deltas.
    
    part3   = 2 * rmidpt * srandel
    srandel2 = srandel * srandel
    
    srandel = rmidpt + SQRT( partr1 + srandel2 - part3 )
    
!              Calculate the inner loop variable value for this trajectory.
    
    ransave = ranmin + srandel
    
  ELSE
    
!              Transfer the previously calculated data
    
    ndata = 1
    CALL swp_7data( ndata )
    
    CALL swp_nextov( inrunno, outrunno, angsave )
    
    GO TO 100
    
  END IF
  
  
!         Increment the inner variable counter.
  
  inrunno = inrunno + 1
  
END IF

!     Initialize the outer loop variable.  This needs to be initialized
!     for each trajectory since the C array is zeroed prior to each
!     trajectory calculation.

c( INT(anglno) ) = angsave

!     Initialize the inner loop element.

c( INT(rangno) ) = ransave

!     Write the new conditions to the tabular file.

CALL swp_6print( inrunno )


RETURN
END SUBROUTINE sweep3_method

SUBROUTINE sweep4_method

!-------------------------------------------------------------------------

!  This module contains the controlling methodology for the CADAC
!  option 4 sweep cases.  In this methodology, NUMR trajectories are
!  performed with the criteria results being printed to a scratch file
!  at the end of each trajectory.  (NUMR is calculated from the
!  user-entered maximum, minimum and delta for the inner variable.)
!  The results are then searched in the order from NUMR, NUMR-1, ... 1,
!  to find the trajectory that produced final data that met the criteria
!  designated by the user.  This trajectory is then used as a starting
!  point for a binary search to more closely find the boundary where the
!  criteria becomes unsatisfied.  The user must specify the number of
!  trajectories executed during the binary search.

!-------------------------------------------------------------------------

!  INRUNNO  - (I) The run number for the inner loop variable.
!  NEXTOV   - (L) Flag for incrementing to the next outer loop value.
!  OUTRUNNO - (I) The counter for the outer loop variable.
!  RANSAVE  - (R) The range(inner variable value) for the current
!             trajectory
!  ANGSAVE  - (R) The angle(outer variable value) for the current
!             trajectory.

!-------------------------------------------------------------------------

INTEGER :: outrunno
LOGICAL :: nextov, goodat, nextsr

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/   jrun, mulrun, igroup


!***  Input

EQUIVALENCE (c(1801), critno )
EQUIVALENCE (c(1803), searno )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )
EQUIVALENCE (c(1824), randel )
EQUIVALENCE (c(1802), critval)

!      SEARNO = The number of trajectories in the binary search
!      ANGLNO = The C element number for the outer variable.
!      RANGNO = The C element number for the inner variable.
!      RANMIN = The minimum value for the inner variable.
!      RANMAX = The maximum value for the inner variable.
!      RANDEL = The delta for the inner variable.


LOGICAL :: mc_err_prt
DATA  mc_err_prt/ .false. /


critvar = c( INT(critno) )

IF( mulrun > 0 ) THEN
  
!         AS OF JULY 1992 (XR92), the determination was made that
!         Monte-Carlo combined with sweep runs would not produce
!         a meaningful set of data when used with option 4 of the
!         sweep methodology.  Perform a check here for Monte-Carlo and
!         sweep option 4 combinations in the input deck.  If they occur,
!         print an error message to the TABOUT file and inhibit the
!         Monte-Carlo option.
  
  IF( .NOT. mc_err_prt  ) THEN
    
!             NOTE:  only print the error message once.
    
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) ' ERROR - TYPE 5 CARD AND SWEEP OPTION 4 IS',  &
        ' AN INVALID COMBINATION '
    WRITE(id_tabout,*)' The max number of runs is being reset'
    WRITE(id_tabout,*)
    
    mc_err_prt = .true.
  END IF
  
!         Reset the multi-run max number of trajectories to 0.
  
  mulrun = 0
END IF


IF( outrunno < 1 ) THEN
  
!         First time through the sweep algorithm.  Perform the
!         initializaiton module.
  
  CALL swp_runinit( inrunno, outrunno, angsave )
  
!         Initialize the flag for incrementing the outer loop:
  
  nextov = .false.
END IF


100 CONTINUE

!     Initialize the outer loop variable.  This needs to be initialized
!     for each trajectory since the C array is zeroed prior to each
!     trajectory calculation.

c( INT(anglno) ) = angsave

CALL swp_critcheck

IF(  inrunno < 1 ) THEN
  
!          The first trajectory for the inner variable.
!          Calculate the number of points between the max and
!          min with this delta.
  
  numr = ( ranmax - ranmin ) / randel + 1.0
  
!          Calculate the maximum number of runs for this inner loop;
!          including the number of binary search runs.
  
  numrmax =  numr + searno
  
!          Save the inner loop value for this trajectory.
  
  ransave = ranmin
  
  
ELSE IF( inrunno < numr ) THEN
  
!          Not finished with the runs along this ray.
!          Increment the inner variable.
  
  ransave = ransave + randel
  
  
ELSE
  
  IF( inrunno < numrmax ) THEN
    
!              At least 1 binary search has been selected to be
!              executed.  Setup for the next trajectory.
    
    IF( inrunno == numr ) THEN
      
!                  Initial trajectory runs have been completed along a
!                  constant outer loop variable.  Search the trajectories
!                  for the first criteria that is satisfied.
      
      CALL swp_findmiss( jgood, nextov, nextsr )
      
!                  If a match was found setup the first binary search.
      
      IF( .NOT.  nextov ) CALL swp_isearch( jgood, ransave, ranhalf )
      
    ELSE
      
!                  Performing the binary searches.
!                  2nd or greater trajectory within the binary search.
      
      CALL swp_halfd( ransave, ranhalf )
      
    END IF
    
    
  ELSE
    
!              Reached the maximum number of binary searches
!              selected by the user.
    
    IF( searno < 1 ) THEN
      
!                  No binary searches were requested.  Copy the
!                  data from the searches satisfying the criteria to
!                  the tape 22.  So first find the trajectory
!                  satisfying the criteria.
      
      CALL swp_findmiss( jgood, nextov, nextsr )
      
!                  Transfer the plot variable data from the scratch
!                  file 7 to the tape 22 data.
      
!---               Comment out this IF so that all impact data will be written
!---               from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---               searches.  This done under XR97
!                   IF( .NOT.  NEXTOV ) CALL SWP_7DATA( JGOOD )
      
    ELSE
      
!                   Binary searches were requested and finished.
!                   Check the last search to insure that the
!                   trajectory was correctly completed and data
!                   on the sweep scratch files is the data for this
!                   RANSAVE.  If it is a match AND the data is not a
!                   miss, transfer the data from file 7 to tape 22
      
      CALL swp_datchk( ransave, goodat, critdat )
      
!---                Comment out this CALL so that all impact data will be written
!---                from IMPACT7.ASC to IMPACT.ASC at the end of each ray after binary
!---                searches.  This done under XR97
!                    IF( GOODAT .AND.  ( CRITDAT .GT. CRITVAL ) ) THEN
!                        NDATA = 1
!                        CALL SWP_7DATA( NDATA )
!                    ENDIF
      
    END IF
    
!              Set the flag to increment to the next outer variable.
    
    nextov = .true.
    
  END IF
  
  
END IF


!---  Check to see if the outer variable is to be incremented


IF( nextov ) THEN
  
!         Sort the data on file 7 (IMPACT7.ASC) in ascending range order
  
  CALL swp_do_sort( inrunno )
  
!         Reset the flag:
  
  nextov = .false.
  
!         Increment to the next outer variable.
  
  CALL swp_nextov( inrunno, outrunno, angsave )
  
  GO TO 100
  
END IF


!     Increment the inner variable counter

inrunno = inrunno + 1

!     Initialize the inner loop element.

c( INT(rangno) ) = ransave

!     Write the new conditions to the tabular file.

CALL swp_6print( inrunno )


!     Go calculate the trajectory for these conditions.

RETURN
END SUBROUTINE sweep4_method

SUBROUTINE sweep5_method

!-------------------------------------------------------------------------

!  This module contains the controlling methodology for the CADAC
!  option 5 sweep cases.  In this methodology, NUMR trajectories are
!  performed with the criteria results being printed to a scratch file
!  at the end of each trajectory.  (NUMR is calculated from the
!  user-entered maximum, minimum and delta for the inner variable.)
!  The results are then searched as each trajectory is generated
!  to find the trajectory that the criteria designated by the user.
!  This trajectory is then used as a starting point for a binary search to
!  more closely find the boundary where the criteria becomes unsatisfied.
!  The user must specify the number of trajectories executed during the
!  binary search.  After the completion of the binary search, the ray
!  trajectories are then continued from the last ray value.
!  This methodology was added under XR97.

!-------------------------------------------------------------------------

!  INRUNNO  - (I) The run number for the inner loop variable.
!  NEXTOV   - (L) Flag for incrementing to the next outer loop value.
!  OUTRUNNO - (I) The counter for the outer loop variable.
!  RANSAVE  - (R) The range(inner variable value) for the current
!             trajectory
!  ANGSAVE  - (R) The angle(outer variable value) for the current
!             trajectory.
!  ISEARUN  - (I) The search run number when searching for the boundary
!             where the criteria is unsatisfied
!  LASTRUN  - (I) The run number at which the criteria has been met and the
!             starting point for the boundary binary search.  Once the boundary
!             has been located, this is the starting point to resume the
!             trajectories along the ray
!  IBOUND   - (I) The boundary for which the searches will try to locate:
!             Boundary 1:  Inner Boundary or Second hole/bayou boundary
!             Boundary 2:  Hole or Bayou

!-------------------------------------------------------------------------

INTEGER :: outrunno
LOGICAL :: nextov, goodat, nextsr

COMMON  c(3510)

COMMON /fileids/ id_cadin,   id_head,    id_csave,   id_tabout,  &
    id_trajbin, id_trajasc, id_statbin, id_statasc,  &
    id_ranvar,  id_impact,  id_impact7, id_impact10,  &
    id_initasc, id_initbin, id_trackasc, id_trackbin

COMMON /krun/   jrun, mulrun, igroup


!***  Input

EQUIVALENCE (c(1803), searno )
EQUIVALENCE (c(1811), anglno )
EQUIVALENCE (c(1821), rangno )
EQUIVALENCE (c(1822), ranmin )
EQUIVALENCE (c(1823), ranmax )
EQUIVALENCE (c(1824), randel )
EQUIVALENCE (c(1802), critval )

!      SEARNO = The number of trajectories in the binary search
!      ANGLNO = The C element number for the outer variable.
!      RANGNO = The C element number for the inner variable.
!      RANMIN = The minimum value for the inner variable.
!      RANMAX = The maximum value for the inner variable.
!      RANDEL = The delta for the inner variable.


LOGICAL :: mc_err_prt
DATA  mc_err_prt/ .false. /



IF( mulrun > 0 ) THEN
  
!         AS OF JULY 1992 (XR92), the determination was made that
!         Monte-Carlo combined with sweep runs would not produce
!         a meaningful set of data when used with option 4 of the
!         sweep methodology.  Perform a check here for Monte-Carlo and
!         sweep option 4 combinations in the input deck.  If they occur,
!         print an error message to the TABOUT file and inhibit the
!         Monte-Carlo option.
  
  IF( .NOT. mc_err_prt  ) THEN
    
!             NOTE:  only print the error message once.
    
    WRITE(id_tabout,*)
    WRITE(id_tabout,*) ' ERROR - TYPE 5 CARD AND SWEEP OPTION 4 IS',  &
        ' AN INVALID COMBINATION '
    WRITE(id_tabout,*)' The max number of runs is being reset'
    WRITE(id_tabout,*)
    
    mc_err_prt = .true.
  END IF
  
!         Reset the multi-run max number of trajectories to 0.
  
  mulrun = 0
END IF


IF( outrunno < 1 ) THEN
  
!         First time through the sweep algorithm.  Perform the
!         initializaiton module.
  
  CALL swp_runinit( inrunno, outrunno, angsave )
  
!         Initialize the flag for incrementing the outer loop:
  
  nextov = .false.
END IF


100 CONTINUE

!     Initialize the outer loop variable.  This needs to be initialized
!     for each trajectory since the C array is zeroed prior to each
!     trajectory calculation.

c( INT(anglno) ) = angsave

CALL swp_critcheck

IF(  inrunno < 1 ) THEN
  
!          The first trajectory for the inner variable.
!          Calculate the number of points between the max and
!          min with this delta.
  
  numr = ( ranmax - ranmin ) / randel + 1.0
  
!          Calculate the maximum number of runs for this inner loop;
!          including the number of binary search runs.
  
  numrmax =  numr + searno
  
!          Save the inner loop value for this trajectory and last run trajectory
  
  ransave = ranmin
  lastrun = ransave
  
!          Initialize the search counter for each boundary binary search
!          Counts from 1 to SEARNO
  
  isearun = 0
  
!          Initialize boundary flag to indicate which boundary to search
  
  ibound = 1
  
ELSE IF( inrunno < numr ) THEN
  
  IF ( isearun < 1 ) THEN
    
!              Check to see if the binary search for a boundary needs to be performed
    IF( ibound == 1 ) THEN
      
      CALL swp_findmiss5( jgood, nextov, nextsr )
      
    ELSE IF( ibound == 2) THEN
      
      CALL swp_findmiss( jgood, nextov, nextsr )
      
    END IF
    
!              Not finished with the runs along this ray.
!              Increment the inner variable.
    
    IF( .NOT. nextsr ) THEN
      
      ransave = ransave + randel
      
!                  Since data is written to the IMPACT.ASC file at the end of each
!                  trajectory, rewind the IMPACT10.ASC file so that the next trajectory
!                  record can be wriiten to the IMPACT10.ASC file.
      REWIND( id_impact10 )
      
    ELSE
      
!                  Setting up first trajectory for binary search
      lastrun = ransave
      
!                  Determine the half delta for searches
      CALL swp_isearch5( ibound, jgood, ransave, ranhalf )
      
!                  New RANSAVE needs to be LASTRUN - RANHALF
!BC                   RANSAVE = LASTRUN - RANHALF
      
!                  Increment the run counters
      isearun = isearun + 1
      numr = numr + 4
      numrmax = numrmax + 4
      
    END IF
    
!              Set the flag to increment the next outer variable
    nextov = .false.
    
  ELSE IF( isearun < searno ) THEN
    
    IF( ibound == 1 ) THEN
      
      CALL swp_halfd( ransave, ranhalf )
      
    ELSE IF( ibound == 2 ) THEN
      
      CALL swp_halfd5( ransave, ranhalf )
      
    END IF
    
!              Increment the run counters
    isearun = isearun + 1
    
!              Set the flag to increment the next outer variable
    nextov = .false.
    
  ELSE
    
!              Reset the run counters
    isearun = 0
    
!              Reset the boundary search flag
    IF( ibound == 1 ) THEN
      ibound = 2
    ELSE IF( ibound == 2 ) THEN
      ibound = 1
    END IF
    
!              Set the next inner variable to the next aimpoint after
!              the binary seach
    ransave = lastrun + randel
    
!             Since data is written to the IMPACT.ASC file at the end of each
!             trajectory, rewind the IMPACT10.ASC file so that the next trajectory
!             record can be wriiten to the IMPACT10.ASC file.
    REWIND( id_impact10 )
    
  END IF
  
ELSE
  
  IF( inrunno < numrmax ) THEN
    
!              At least 1 binary search has been selected to be
!              executed.  Setup for the next trajectory.
    
    IF( inrunno == numr ) THEN
      
!                  Initial trajectory runs have been completed along a
!                  constant outer loop variable.  Search the trajectories
!                  for the first criteria that is satisfied.
      
      CALL swp_findmiss( jgood, nextov, nextsr )
      
!                  If a match was found setup the first binary search.
      
      IF( .NOT.  nextov ) CALL swp_isearch( jgood, ransave, ranhalf )
      
    ELSE
      
!                  Performing the binary searches.
!                  2nd or greater trajectory within the binary search.
      
      CALL swp_halfd( ransave, ranhalf )
      
    END IF
    
    
  ELSE
    
!              Reached the maximum number of binary searches
!              selected by the user.
    
    IF( searno < 1 ) THEN
      
!                  No binary searches were requested.  Copy the
!                  data from the searches satisfying the criteria to
!                  the tape 22.  So first find the trajectory
!                  satisfying the criteria.
      
      CALL swp_findmiss( jgood, nextov, nextsr )
      
!                  Transfer the plot variable data from the scratch
!                  file 7 to the tape 22 data.
      
      IF( .NOT.  nextov ) CALL swp_7data( jgood )
      
    ELSE
      
!                   Binary searches were requested and finished.
!                   Check the last search to insure that the
!                   trajectory was correctly completed and data
!                   on the sweep scratch files is the data for this
!                   RANSAVE.  If it is a match AND the data is not a
!                   miss, transfer the data from file 7 to tape 22
      
      CALL swp_datchk( ransave, goodat, critdat )
      
    END IF
    
!              Set the flag to increment to the next outer variable.
    
    nextov = .true.
    
  END IF
  
  
END IF


!---  Check to see if the outer variable is to be incremented


IF( nextov ) THEN
  
!         Sort the data on file 7 (IMPACT7.ASC) in ascending range order
  
  CALL swp_do_sort( inrunno )
  
!         Reset the flag:
  
  nextov = .false.
  
!         Increment to the next outer variable.
  
  CALL swp_nextov( inrunno, outrunno, angsave )
  
  GO TO 100
  
END IF


!     Increment the inner variable counter

inrunno = inrunno + 1

!     Initialize the inner loop element.

c( INT(rangno) ) = ransave

!     Write the new conditions to the tabular file.

CALL swp_6print( inrunno )


!     Go calculate the trajectory for these conditions.

RETURN
END SUBROUTINE sweep5_method

SUBROUTINE ld_minmax

!-------------------------------------------------------------------------

!  This module compares the current data to previous data to find the
!  minimum/maximum plot values.  The module insures that time is loaded at
!  the first variable.

!--Local Variable Definitions-------------------------------------------

!  PRDATA - (R) The array of current data.

!-------------------------------------------------------------------------

DIMENSION prdata(70)

COMMON         c(3510)

COMMON /opplot/ ipladd(70), intplot(70)
LOGICAL :: intplot

DIMENSION   ic(3510), pmin(70)

EQUIVALENCE (c(0001), ic(0001) )
EQUIVALENCE (c(2127), pmin(1)  )
EQUIVALENCE (c(2280), nv    )


!     Force C(2000), TIME, as the first variable

ipladd(1) = 2000

!     Load the arrays for printing to the plot data file.
!     NV = Number of plot variables

DO i = 1, nv
  
!        Load the current value of the plot variable
  
  IF( intplot(i) ) THEN
    prdata(i) = ic( ipladd(i) )
  ELSE
    prdata(i) = c( ipladd(i) )
  END IF
  
!        Determine the minimum of the variable compared with the
!        previous minimum values (and 0 since the C array is initialized
!        to 0)
  
  pmin(i) = AMIN1( prdata(i), pmin(i) )
END DO


RETURN
END SUBROUTINE ld_minmax

!---------------------------------------------------------

!     PC Version Code

!---------------------------------------------------------

SUBROUTINE str_upcase(linein, lineout)

!----------------------------------------------------------------------

!     This module converts a string to all uppercase letters.

!----------------------------------------------------------------------


CHARACTER (LEN=*), INTENT(IN)            :: linein
CHARACTER (LEN=*), INTENT(OUT)           :: lineout

INTEGER :: asc_val

lineout = linein
line_len = lenstr(lineout)
DO i = 1, line_len
  asc_val = ICHAR(lineout(i:i))
  IF( asc_val >= 97 .AND. asc_val <= 122 ) THEN
    lineout(i:i) = CHAR( asc_val - 32 )
  END IF
END DO

RETURN
END SUBROUTINE str_upcase

FUNCTION lenstr( thestring )

!----------------------------------------------------------------------

!  This function searches the text contained in the string variable for
!  the end of the text.  The function returns the character location
!  of the last non-blank character location.  This is useful in
!  locating the end of text within a string.  The module will work
!  with any length input string.

!----------------------------------------------------------------------

!  THESTRING - (C) Input.  The character string to be searched for the
!                  end of the text string.

!  LENSTR - (I) The location of the last non-blank character in
!               THESTRING.  A 0 value is returned if the string is
!               completely blank

!----------------------------------------------------------------------



CHARACTER (LEN=*), INTENT(IN)            :: thestring


length = LEN( thestring )

DO WHILE ( length > 0 .AND. thestring(length:length) == ' ' )
  length = length - 1
END DO

lenstr = length
RETURN
END FUNCTION lenstr

